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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-07-11 21:41:48 -05:00
parent 6a4cfbce27 b668936d9f
commit d6b3c906aa
65 changed files with 573 additions and 789 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
core/bootstrap/image/image.factor
View File

@ -85,8 +85,16 @@ SYMBOL: objects
: 1-offset 8 ; inline : 1-offset 8 ; inline
: -1-offset 9 ; inline : -1-offset 9 ; inline
SYMBOL: sub-primitives
: make-jit ( quot rc rt offset -- quad )
{ [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
: jit-define ( quot rc rt offset name -- ) : jit-define ( quot rc rt offset name -- )
>r { [ { } make ] [ ] [ ] [ ] } spread 4array r> set ; >r make-jit r> set ; inline
: define-sub-primitive ( quot rc rt offset word -- )
>r make-jit r> sub-primitives get set-at ;
! The image being constructed; a vector of word-size integers ! The image being constructed; a vector of word-size integers
SYMBOL: image SYMBOL: image
@ -118,29 +126,7 @@ SYMBOL: jit-dispatch
SYMBOL: jit-epilog SYMBOL: jit-epilog
SYMBOL: jit-return SYMBOL: jit-return
SYMBOL: jit-profiling SYMBOL: jit-profiling
SYMBOL: jit-tag
SYMBOL: jit-tag-word
SYMBOL: jit-eq?
SYMBOL: jit-eq?-word
SYMBOL: jit-slot
SYMBOL: jit-slot-word
SYMBOL: jit-declare-word SYMBOL: jit-declare-word
SYMBOL: jit-drop
SYMBOL: jit-drop-word
SYMBOL: jit-dup
SYMBOL: jit-dup-word
SYMBOL: jit->r
SYMBOL: jit->r-word
SYMBOL: jit-r>
SYMBOL: jit-r>-word
SYMBOL: jit-swap
SYMBOL: jit-swap-word
SYMBOL: jit-over
SYMBOL: jit-over-word
SYMBOL: jit-fixnum-fast
SYMBOL: jit-fixnum-fast-word
SYMBOL: jit-fixnum>=
SYMBOL: jit-fixnum>=-word
! Default definition for undefined words ! Default definition for undefined words
SYMBOL: undefined-quot SYMBOL: undefined-quot
@ -163,29 +149,7 @@ SYMBOL: undefined-quot
{ jit-epilog 33 } { jit-epilog 33 }
{ jit-return 34 } { jit-return 34 }
{ jit-profiling 35 } { jit-profiling 35 }
{ jit-tag 36 }
{ jit-tag-word 37 }
{ jit-eq? 38 }
{ jit-eq?-word 39 }
{ jit-slot 40 }
{ jit-slot-word 41 }
{ jit-declare-word 42 } { jit-declare-word 42 }
{ jit-drop 43 }
{ jit-drop-word 44 }
{ jit-dup 45 }
{ jit-dup-word 46 }
{ jit->r 47 }
{ jit->r-word 48 }
{ jit-r> 49 }
{ jit-r>-word 50 }
{ jit-swap 51 }
{ jit-swap-word 52 }
{ jit-over 53 }
{ jit-over-word 54 }
{ jit-fixnum-fast 55 }
{ jit-fixnum-fast-word 56 }
{ jit-fixnum>= 57 }
{ jit-fixnum>=-word 58 }
{ undefined-quot 60 } { undefined-quot 60 }
} at header-size + ; } at header-size + ;
@ -305,6 +269,9 @@ M: f '
! Words ! Words
: word-sub-primitive ( word -- obj )
global [ target-word ] bind sub-primitives get at ;
: emit-word ( word -- ) : emit-word ( word -- )
[ [
[ subwords [ emit-word ] each ] [ subwords [ emit-word ] each ]
@ -316,12 +283,13 @@ M: f '
[ vocabulary>> , ] [ vocabulary>> , ]
[ def>> , ] [ def>> , ]
[ props>> , ] [ props>> , ]
[ drop f , ]
[ drop 0 , ] ! count
[ word-sub-primitive , ]
[ drop 0 , ] ! xt
[ drop 0 , ] ! code
[ drop 0 , ] ! profiling
} cleave } cleave
f ,
0 , ! count
0 , ! xt
0 , ! code
0 , ! profiling
] { } make [ ' ] map ] { } make [ ' ] map
] bi ] bi
\ word type-number object tag-number \ word type-number object tag-number
@ -460,18 +428,7 @@ M: quotation '
\ if jit-if-word set \ if jit-if-word set
\ dispatch jit-dispatch-word set \ dispatch jit-dispatch-word set
\ do-primitive jit-primitive-word set \ do-primitive jit-primitive-word set
\ tag jit-tag-word set
\ eq? jit-eq?-word set
\ slot jit-slot-word set
\ declare jit-declare-word set \ declare jit-declare-word set
\ drop jit-drop-word set
\ dup jit-dup-word set
\ >r jit->r-word set
\ r> jit-r>-word set
\ swap jit-swap-word set
\ over jit-over-word set
\ fixnum-fast jit-fixnum-fast-word set
\ fixnum>= jit-fixnum>=-word set
[ undefined ] undefined-quot set [ undefined ] undefined-quot set
{ {
jit-code-format jit-code-format
@ -488,29 +445,7 @@ M: quotation '
jit-epilog jit-epilog
jit-return jit-return
jit-profiling jit-profiling
jit-tag
jit-tag-word
jit-eq?
jit-eq?-word
jit-slot
jit-slot-word
jit-declare-word jit-declare-word
jit-drop
jit-drop-word
jit-dup
jit-dup-word
jit->r
jit->r-word
jit-r>
jit-r>-word
jit-swap
jit-swap-word
jit-over
jit-over-word
jit-fixnum-fast
jit-fixnum-fast-word
jit-fixnum>=
jit-fixnum>=-word
undefined-quot undefined-quot
} [ emit-userenv ] each ; } [ emit-userenv ] each ;

80
core/bootstrap/primitives.factor
View File

@ -13,6 +13,8 @@ IN: bootstrap.primitives
crossref off crossref off
H{ } clone sub-primitives set
"resource:core/bootstrap/syntax.factor" parse-file "resource:core/bootstrap/syntax.factor" parse-file
"resource:core/cpu/" architecture get { "resource:core/cpu/" architecture get {
@ -256,6 +258,7 @@ bi
"props" "props"
{ "compiled" read-only } { "compiled" read-only }
{ "counter" { "fixnum" "math" } } { "counter" { "fixnum" "math" } }
{ "sub-primitive" read-only }
} define-builtin } define-builtin
"byte-array" "byte-arrays" create { } define-builtin "byte-array" "byte-arrays" create { } define-builtin
@ -323,14 +326,55 @@ tuple
[ tuple-layout [ <tuple-boa> ] curry ] tri [ tuple-layout [ <tuple-boa> ] curry ] tri
(( quot1 quot2 -- compose )) define-declared (( quot1 quot2 -- compose )) define-declared
! Sub-primitive words
: make-sub-primitive ( word vocab -- )
create
dup reset-word
dup 1quotation define ;
{
{ "(execute)" "words.private" }
{ "(call)" "kernel.private" }
{ "fixnum+fast" "math.private" }
{ "fixnum-fast" "math.private" }
{ "fixnum*fast" "math.private" }
{ "fixnum-bitand" "math.private" }
{ "fixnum-bitor" "math.private" }
{ "fixnum-bitxor" "math.private" }
{ "fixnum-bitnot" "math.private" }
{ "fixnum<" "math.private" }
{ "fixnum<=" "math.private" }
{ "fixnum>" "math.private" }
{ "fixnum>=" "math.private" }
{ "drop" "kernel" }
{ "2drop" "kernel" }
{ "3drop" "kernel" }
{ "dup" "kernel" }
{ "2dup" "kernel" }
{ "3dup" "kernel" }
{ "rot" "kernel" }
{ "-rot" "kernel" }
{ "dupd" "kernel" }
{ "swapd" "kernel" }
{ "nip" "kernel" }
{ "2nip" "kernel" }
{ "tuck" "kernel" }
{ "over" "kernel" }
{ "pick" "kernel" }
{ "swap" "kernel" }
{ ">r" "kernel" }
{ "r>" "kernel" }
{ "eq?" "kernel" }
{ "tag" "kernel.private" }
{ "slot" "slots.private" }
} [ make-sub-primitive ] assoc-each
! Primitive words ! Primitive words
: make-primitive ( word vocab n -- ) : make-primitive ( word vocab n -- )
>r create dup reset-word r> >r create dup reset-word r>
[ do-primitive ] curry [ ] like define ; [ do-primitive ] curry [ ] like define ;
{ {
{ "(execute)" "words.private" }
{ "(call)" "kernel.private" }
{ "bignum>fixnum" "math.private" } { "bignum>fixnum" "math.private" }
{ "float>fixnum" "math.private" } { "float>fixnum" "math.private" }
{ "fixnum>bignum" "math.private" } { "fixnum>bignum" "math.private" }
@ -346,24 +390,13 @@ tuple
{ "bits>double" "math" } { "bits>double" "math" }
{ "<complex>" "math.private" } { "<complex>" "math.private" }
{ "fixnum+" "math.private" } { "fixnum+" "math.private" }
{ "fixnum+fast" "math.private" }
{ "fixnum-" "math.private" } { "fixnum-" "math.private" }
{ "fixnum-fast" "math.private" }
{ "fixnum*" "math.private" } { "fixnum*" "math.private" }
{ "fixnum*fast" "math.private" }
{ "fixnum/i" "math.private" } { "fixnum/i" "math.private" }
{ "fixnum-mod" "math.private" } { "fixnum-mod" "math.private" }
{ "fixnum/mod" "math.private" } { "fixnum/mod" "math.private" }
{ "fixnum-bitand" "math.private" }
{ "fixnum-bitor" "math.private" }
{ "fixnum-bitxor" "math.private" }
{ "fixnum-bitnot" "math.private" }
{ "fixnum-shift" "math.private" } { "fixnum-shift" "math.private" }
{ "fixnum-shift-fast" "math.private" } { "fixnum-shift-fast" "math.private" }
{ "fixnum<" "math.private" }
{ "fixnum<=" "math.private" }
{ "fixnum>" "math.private" }
{ "fixnum>=" "math.private" }
{ "bignum=" "math.private" } { "bignum=" "math.private" }
{ "bignum+" "math.private" } { "bignum+" "math.private" }
{ "bignum-" "math.private" } { "bignum-" "math.private" }
@ -395,25 +428,6 @@ tuple
{ "float>=" "math.private" } { "float>=" "math.private" }
{ "<word>" "words" } { "<word>" "words" }
{ "word-xt" "words" } { "word-xt" "words" }
{ "drop" "kernel" }
{ "2drop" "kernel" }
{ "3drop" "kernel" }
{ "dup" "kernel" }
{ "2dup" "kernel" }
{ "3dup" "kernel" }
{ "rot" "kernel" }
{ "-rot" "kernel" }
{ "dupd" "kernel" }
{ "swapd" "kernel" }
{ "nip" "kernel" }
{ "2nip" "kernel" }
{ "tuck" "kernel" }
{ "over" "kernel" }
{ "pick" "kernel" }
{ "swap" "kernel" }
{ ">r" "kernel" }
{ "r>" "kernel" }
{ "eq?" "kernel" }
{ "getenv" "kernel.private" } { "getenv" "kernel.private" }
{ "setenv" "kernel.private" } { "setenv" "kernel.private" }
{ "(exists?)" "io.files.private" } { "(exists?)" "io.files.private" }
@ -433,7 +447,6 @@ tuple
{ "code-room" "memory" } { "code-room" "memory" }
{ "os-env" "system" } { "os-env" "system" }
{ "millis" "system" } { "millis" "system" }
{ "tag" "kernel.private" }
{ "modify-code-heap" "compiler.units" } { "modify-code-heap" "compiler.units" }
{ "dlopen" "alien" } { "dlopen" "alien" }
{ "dlsym" "alien" } { "dlsym" "alien" }
@ -468,7 +481,6 @@ tuple
{ "set-alien-cell" "alien.accessors" } { "set-alien-cell" "alien.accessors" }
{ "(throw)" "kernel.private" } { "(throw)" "kernel.private" }
{ "alien-address" "alien" } { "alien-address" "alien" }
{ "slot" "slots.private" }
{ "set-slot" "slots.private" } { "set-slot" "slots.private" }
{ "string-nth" "strings.private" } { "string-nth" "strings.private" }
{ "set-string-nth" "strings.private" } { "set-string-nth" "strings.private" }

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

@ -18,8 +18,8 @@ IN: compiler.constants
: underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; : underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ;
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ;
: class-hash-offset ( -- n ) bootstrap-cell object tag-number - ; : class-hash-offset ( -- n ) bootstrap-cell object tag-number - ;
: word-xt-offset ( -- n ) 8 bootstrap-cells object tag-number - ; : word-xt-offset ( -- n ) 9 bootstrap-cells object tag-number - ;
: quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ; : quot-xt-offset ( -- n ) 3 bootstrap-cells object tag-number - ;
: word-code-offset ( -- n ) 9 bootstrap-cells object tag-number - ; : word-code-offset ( -- n ) 10 bootstrap-cells object tag-number - ;
: array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ; : array-start-offset ( -- n ) 2 bootstrap-cells object tag-number - ;
: compiled-header-size ( -- n ) 4 bootstrap-cells ; : compiled-header-size ( -- n ) 4 bootstrap-cells ;

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

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: bootstrap.image.private kernel namespaces system USING: bootstrap.image.private kernel kernel.private namespaces
cpu.x86.assembler layouts compiler.units math generator.fixup system cpu.x86.assembler layouts compiler.units math math.private
compiler.constants vocabs ; generator.fixup compiler.constants vocabs slots.private words
words.private ;
IN: bootstrap.x86 IN: bootstrap.x86
big-endian off big-endian off
@ -74,27 +75,34 @@ big-endian off
arg0 quot-xt-offset [+] JMP ! execute branch arg0 quot-xt-offset [+] JMP ! execute branch
] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
[
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame
] f f f jit-epilog jit-define
[ 0 RET ] f f f jit-return jit-define
! Sub-primitives
! Quotations and words
[
arg0 ds-reg [] MOV ! load from stack
ds-reg bootstrap-cell SUB ! pop stack
arg0 quot-xt-offset [+] JMP ! call quotation
] f f f \ (call) define-sub-primitive
[
arg0 ds-reg [] MOV ! load from stack
ds-reg bootstrap-cell SUB ! pop stack
arg0 word-xt-offset [+] JMP ! execute word
] f f f \ (execute) define-sub-primitive
! Objects
[ [
arg1 ds-reg [] MOV ! load from stack arg1 ds-reg [] MOV ! load from stack
arg1 tag-mask get AND ! compute tag arg1 tag-mask get AND ! compute tag
arg1 tag-bits get SHL ! tag the tag arg1 tag-bits get SHL ! tag the tag
ds-reg [] arg1 MOV ! push to stack ds-reg [] arg1 MOV ! push to stack
] f f f jit-tag jit-define ] f f f \ tag define-sub-primitive
: jit-compare ( -- )
arg1 0 MOV ! load t
arg1 dup [] MOV
temp-reg \ f tag-number MOV ! load f
arg0 ds-reg [] MOV ! load first value
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] arg0 CMP ! compare with second value
;
[
jit-compare
arg1 temp-reg CMOVNE ! not equal?
ds-reg [] arg1 MOV ! store
] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define
[ [
arg0 ds-reg [] MOV ! load slot number arg0 ds-reg [] MOV ! load slot number
@ -105,63 +113,187 @@ big-endian off
arg1 tag-bits get SHL arg1 tag-bits get SHL
arg0 arg1 arg0 [+] MOV ! load slot value arg0 arg1 arg0 [+] MOV ! load slot value
ds-reg [] arg0 MOV ! push to stack ds-reg [] arg0 MOV ! push to stack
] f f f jit-slot jit-define ] f f f \ slot define-sub-primitive
! Shufflers
[ [
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
] f f f jit-drop jit-define ] f f f \ drop define-sub-primitive
[
ds-reg 2 bootstrap-cells SUB
] f f f \ 2drop define-sub-primitive
[
ds-reg 3 bootstrap-cells SUB
] f f f \ 3drop define-sub-primitive
[ [
arg0 ds-reg [] MOV arg0 ds-reg [] MOV
ds-reg bootstrap-cell ADD ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV ds-reg [] arg0 MOV
] f f f jit-dup jit-define ] f f f \ dup define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg bootstrap-cell neg [+] MOV
ds-reg 2 bootstrap-cells ADD
ds-reg [] arg0 MOV
ds-reg bootstrap-cell neg [+] arg1 MOV
] f f f \ 2dup define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
temp-reg ds-reg -2 bootstrap-cells [+] MOV
ds-reg 3 bootstrap-cells ADD
ds-reg [] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV
ds-reg -2 bootstrap-cells [+] temp-reg MOV
] f f f \ 3dup define-sub-primitive
[ [
rs-reg bootstrap-cell ADD
arg0 ds-reg [] MOV arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB ds-reg bootstrap-cell SUB
rs-reg [] arg0 MOV ds-reg [] arg0 MOV
] f f f jit->r jit-define ] f f f \ nip define-sub-primitive
[ [
ds-reg bootstrap-cell ADD arg0 ds-reg [] MOV
arg0 rs-reg [] MOV ds-reg 2 bootstrap-cells SUB
rs-reg bootstrap-cell SUB
ds-reg [] arg0 MOV ds-reg [] arg0 MOV
] f f f jit-r> jit-define ] f f f \ 2nip define-sub-primitive
[
arg0 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
] f f f \ over define-sub-primitive
[
arg0 ds-reg -2 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
] f f f \ pick define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg [] arg1 MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
] f f f \ dupd define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD
ds-reg [] arg0 MOV
ds-reg -1 bootstrap-cells [+] arg1 MOV
ds-reg -2 bootstrap-cells [+] arg0 MOV
] f f f \ tuck define-sub-primitive
[ [
arg0 ds-reg [] MOV arg0 ds-reg [] MOV
arg1 ds-reg bootstrap-cell neg [+] MOV arg1 ds-reg bootstrap-cell neg [+] MOV
ds-reg bootstrap-cell neg [+] arg0 MOV ds-reg bootstrap-cell neg [+] arg0 MOV
ds-reg [] arg1 MOV ds-reg [] arg1 MOV
] f f f jit-swap jit-define ] f f f \ swap define-sub-primitive
[ [
arg0 ds-reg bootstrap-cell neg [+] MOV arg0 ds-reg -1 bootstrap-cells [+] MOV
ds-reg bootstrap-cell ADD arg1 ds-reg -2 bootstrap-cells [+] MOV
ds-reg [] arg0 MOV ds-reg -2 bootstrap-cells [+] arg0 MOV
] f f f jit-over jit-define ds-reg -1 bootstrap-cells [+] arg1 MOV
] f f f \ swapd define-sub-primitive
[ [
arg0 ds-reg [] MOV arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB arg1 ds-reg -1 bootstrap-cells [+] MOV
arg1 ds-reg [] MOV temp-reg ds-reg -2 bootstrap-cells [+] MOV
arg1 arg0 SUB ds-reg -2 bootstrap-cells [+] arg1 MOV
ds-reg -1 bootstrap-cells [+] arg0 MOV
ds-reg [] temp-reg MOV
] f f f \ rot define-sub-primitive
[
arg0 ds-reg [] MOV
arg1 ds-reg -1 bootstrap-cells [+] MOV
temp-reg ds-reg -2 bootstrap-cells [+] MOV
ds-reg -2 bootstrap-cells [+] arg0 MOV
ds-reg -1 bootstrap-cells [+] temp-reg MOV
ds-reg [] arg1 MOV ds-reg [] arg1 MOV
] f f f jit-fixnum-fast jit-define ] f f f \ -rot define-sub-primitive
[ [
jit-compare rs-reg bootstrap-cell ADD
arg1 temp-reg CMOVL ! not equal? arg0 ds-reg [] MOV
ds-reg bootstrap-cell SUB
rs-reg [] arg0 MOV
] f f f \ >r define-sub-primitive
[
ds-reg bootstrap-cell ADD
arg0 rs-reg [] MOV
rs-reg bootstrap-cell SUB
ds-reg [] arg0 MOV
] f f f \ r> define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
arg1 0 MOV ! load t
arg1 dup [] MOV
temp-reg \ f tag-number MOV ! load f
arg0 ds-reg [] MOV ! load first value
ds-reg bootstrap-cell SUB ! adjust stack pointer
ds-reg [] arg0 CMP ! compare with second value
[ arg1 temp-reg ] dip execute ! move t if true
ds-reg [] arg1 MOV ! store ds-reg [] arg1 MOV ! store
] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define ;
: define-jit-compare ( insn word -- )
[ [ jit-compare ] curry rc-absolute-cell rt-literal 1 rex-length + ] dip
define-sub-primitive ;
\ CMOVNE \ eq? define-jit-compare
\ CMOVL \ fixnum>= define-jit-compare
\ CMOVG \ fixnum<= define-jit-compare
\ CMOVLE \ fixnum> define-jit-compare
\ CMOVGE \ fixnum< define-jit-compare
! Math
: jit-math ( insn -- )
arg0 ds-reg [] MOV ! load second input
ds-reg bootstrap-cell SUB ! pop stack
arg1 ds-reg [] MOV ! load first input
[ arg1 arg0 ] dip execute ! compute result
ds-reg [] arg1 MOV ! push result
;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
[ \ SUB jit-math ] f f f \ fixnum-fast define-sub-primitive
[ [
stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame arg0 ds-reg [] MOV ! load second input
] f f f jit-epilog jit-define ds-reg bootstrap-cell SUB ! pop stack
arg1 ds-reg [] MOV ! load first input
arg0 tag-bits get SAR ! untag second input
arg0 arg1 IMUL2 ! multiply
ds-reg [] arg1 MOV ! push result
] f f f \ fixnum*fast define-sub-primitive
[ 0 RET ] f f f jit-return jit-define [ \ AND jit-math ] f f f \ fixnum-bitand define-sub-primitive
[ \ OR jit-math ] f f f \ fixnum-bitor define-sub-primitive
[ \ XOR jit-math ] f f f \ fixnum-bitxor define-sub-primitive
[
arg0 ds-reg [] MOV ! load input input
arg0 NOT ! complement
arg0 tag-mask get XOR ! clear tag bits
ds-reg [] arg0 MOV ! save
] f f f \ fixnum-bitnot define-sub-primitive
[ "bootstrap.x86" forget-vocab ] with-compilation-unit [ "bootstrap.x86" forget-vocab ] with-compilation-unit

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

@ -104,6 +104,8 @@ M: object infer-call
] if ] if
] "infer" set-word-prop ] "infer" set-word-prop
\ execute t "no-compile" set-word-prop
\ if [ \ if [
3 ensure-values 3 ensure-values
2 d-tail [ special? ] contains? [ 2 d-tail [ special? ] contains? [
@ -123,6 +125,8 @@ M: object infer-call
[ #dispatch ] infer-branches [ #dispatch ] infer-branches
] "infer" set-word-prop ] "infer" set-word-prop
\ dispatch t "no-compile" set-word-prop
\ curry [ \ curry [
2 ensure-values 2 ensure-values
pop-d pop-d swap <curried> push-d pop-d pop-d swap <curried> push-d

4
core/words/words.factor
View File

@ -34,7 +34,9 @@ M: symbol definer drop \ SYMBOL: f ;
M: symbol definition drop f ; M: symbol definition drop f ;
PREDICATE: primitive < word ( obj -- ? ) PREDICATE: primitive < word ( obj -- ? )
def>> [ do-primitive ] tail? ; [ def>> [ do-primitive ] tail? ]
[ sub-primitive>> >boolean ]
bi or ;
M: primitive definer drop \ PRIMITIVE: f ; M: primitive definer drop \ PRIMITIVE: f ;
M: primitive definition drop f ; M: primitive definition drop f ;

2
extra/automata/ui/ui.factor
View File

@ -15,7 +15,7 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads
ui.gadgets.grids ui.gadgets.grids
ui.gadgets.theme ui.gadgets.theme
namespaces.lib assocs.lib vars namespaces.lib assocs.lib vars
rewrite-closures automata ; rewrite-closures automata math.geometry.rect ;
IN: automata.ui IN: automata.ui

25
extra/boids/boids.factor
View File

@ -6,14 +6,17 @@ USING: combinators.short-circuit kernel namespaces
math.order math.order
math.vectors math.vectors
math.trig math.trig
math.physics.pos
math.physics.vel
combinators arrays sequences random vars combinators arrays sequences random vars
combinators.lib ; combinators.lib
accessors ;
IN: boids IN: boids
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: boid pos vel ; TUPLE: boid < vel ;
C: <boid> boid C: <boid> boid
@ -70,7 +73,7 @@ VAR: separation-radius
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: distance ( boid boid -- n ) [ boid-pos ] [ boid-pos ] bi* v- norm ; : distance ( boid boid -- n ) [ pos>> ] [ pos>> ] bi* v- norm ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -81,10 +84,10 @@ VAR: separation-radius
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: relative-position ( self other -- v ) swap [ boid-pos ] bi@ v- ; : relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
: relative-angle ( self other -- angle ) : relative-angle ( self other -- angle )
over boid-vel -rot relative-position angle-between ; over vel>> -rot relative-position angle-between ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -92,9 +95,9 @@ over boid-vel -rot relative-position angle-between ;
: vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ; : vaverage ( seq-of-vectors -- seq ) [ vsum ] [ length ] bi v/n ;
: average-position ( boids -- pos ) [ boid-pos ] map vaverage ; : average-position ( boids -- pos ) [ pos>> ] map vaverage ;
: average-velocity ( boids -- vel ) [ boid-vel ] map vaverage ; : average-velocity ( boids -- vel ) [ vel>> ] map vaverage ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -123,7 +126,7 @@ over boid-vel -rot relative-position angle-between ;
dup cohesion-neighborhood dup cohesion-neighborhood
dup empty? dup empty?
[ 2drop { 0 0 } ] [ 2drop { 0 0 } ]
[ average-position swap boid-pos v- normalize* cohesion-weight> v*n ] [ average-position swap pos>> v- normalize* cohesion-weight> v*n ]
if ; if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -143,7 +146,7 @@ over boid-vel -rot relative-position angle-between ;
dup separation-neighborhood dup separation-neighborhood
dup empty? dup empty?
[ 2drop { 0 0 } ] [ 2drop { 0 0 } ]
[ average-position swap boid-pos swap v- normalize* separation-weight> v*n ] [ average-position swap pos>> swap v- normalize* separation-weight> v*n ]
if ; if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -206,10 +209,10 @@ cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: new-pos ( boid -- pos ) [ boid-pos ] [ boid-vel time-slice> v*n ] bi v+ ; : new-pos ( boid -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
: new-vel ( boid -- vel ) : new-vel ( boid -- vel )
[ boid-vel ] [ acceleration time-slice> v*n ] bi v+ normalize* ; [ vel>> ] [ acceleration time-slice> v*n ] bi v+ normalize* ;
: wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ; : wrap-pos ( pos -- pos ) { [ wrap-x ] [ wrap-y ] } parallel-call ;

7
extra/boids/ui/ui.factor
View File

@ -19,7 +19,8 @@ USING: combinators.short-circuit kernel namespaces
ui.gadgets.packs ui.gadgets.packs
ui.gadgets.grids ui.gadgets.grids
ui.gestures ui.gestures
assocs.lib vars rewrite-closures boids ; assocs.lib vars rewrite-closures boids accessors
math.geometry.rect ;
IN: boids.ui IN: boids.ui
@ -27,9 +28,9 @@ IN: boids.ui
! draw-boid ! draw-boid
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: point-a ( boid -- a ) boid-pos ; : point-a ( boid -- a ) pos>> ;
: point-b ( boid -- b ) [ boid-pos ] [ boid-vel normalize* 20 v*n ] bi v+ ; : point-b ( boid -- b ) [ pos>> ] [ vel>> normalize* 20 v*n ] bi v+ ;
: boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ; : boid-points ( boid -- point-a point-b ) [ point-a ] [ point-b ] bi ;

2
extra/color-picker/color-picker.factor
View File

@ -3,7 +3,7 @@
USING: kernel math math.functions math.parser models USING: kernel math math.functions math.parser models
models.filter models.range models.compose sequences ui models.filter models.range models.compose sequences ui
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
ui.gadgets.sliders ui.render ; ui.gadgets.sliders ui.render math.geometry.rect ;
IN: color-picker IN: color-picker
! Simple example demonstrating the use of models. ! Simple example demonstrating the use of models.

4
extra/irc/ui/ui.factor
View File

@ -82,10 +82,10 @@ M: irc-message write-irc
<scrolling-pane> <scrolling-pane>
[ <pane-stream> swap display ] keep ; [ <pane-stream> swap display ] keep ;
TUPLE: irc-editor outstream listener client ; TUPLE: irc-editor < editor outstream listener client ;
: <irc-editor> ( pane listener client -- editor ) : <irc-editor> ( pane listener client -- editor )
[ <editor> irc-editor construct-editor [ irc-editor new-editor
swap >>listener swap <pane-stream> >>outstream swap >>listener swap <pane-stream> >>outstream
] dip client>> >>client ; ] dip client>> >>client ;

5
extra/jamshred/jamshred.factor
View File

@ -1,6 +1,9 @@
! Copyright (C) 2007, 2008 Alex Chapman ! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ; USING: accessors alarms arrays calendar jamshred.game jamshred.gl
jamshred.player jamshred.log kernel math math.constants namespaces
sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds
ui.gestures ui.render math.vectors math.geometry.rect ;
IN: jamshred IN: jamshred
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;

54
extra/math/geometry/rect/rect-docs.factor Normal file
View File

@ -0,0 +1,54 @@
USING: help.markup help.syntax ;
IN: math.geometry.rect
HELP: rect
{ $class-description "A rectangle with the following slots:"
{ $list
{ { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" }
{ { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" }
}
"Rectangles are constructed by calling " { $link <rect> } " and " { $link <extent-rect> } "."
} ;
HELP: <rect> ( loc dim -- rect )
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } }
{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ;
{ <zero-rect> <rect> <extent-rect> } related-words
HELP: set-rect-dim ( dim rect -- )
{ $values { "dim" "a pair of integers" } { "rect" rect } }
{ $description "Modifies the dimensions of a rectangle." }
{ $side-effects "rect" } ;
HELP: rect-bounds
{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
{ $description "Outputs the location and dimensions of a rectangle." } ;
{ rect-bounds rect-extent } related-words
HELP: <extent-rect> ( loc ext -- rect )
{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } }
{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ;
HELP: rect-extent
{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ;
HELP: offset-rect
{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } }
{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ;
HELP: rect-intersect
{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } }
{ $description "Computes the intersection of two rectangles." } ;
HELP: intersects?
{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } }
{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ;
HELP: <zero-rect>
{ $values { "rect" "a new " { $link rect } } }
{ $description "Creates a rectangle located at the origin with zero dimensions." } ;

42
extra/math/geometry/rect/rect.factor Normal file
View File

@ -0,0 +1,42 @@
USING: kernel arrays math.vectors ;
IN: math.geometry.rect
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
: <zero-rect> ( -- rect ) rect new ;
C: <rect> rect
M: array rect-loc ;
M: array rect-dim drop { 0 0 } ;
: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
[ rect-extent ] bi@ swapd ;
: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
: offset-rect ( rect loc -- newrect )
over rect-loc v+ swap rect-dim <rect> ;
: (rect-intersect) ( rect rect -- array array )
2rect-extent vmin >r vmax r> ;
: rect-intersect ( rect1 rect2 -- newrect )
(rect-intersect) <extent-rect> ;
: intersects? ( rect/point rect -- ? )
(rect-intersect) [v-] { 0 0 } = ;
: (rect-union) ( rect rect -- array array )
2rect-extent vmax >r vmin r> ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;

5
extra/math/physics/pos/pos.factor Normal file
View File

@ -0,0 +1,5 @@
IN: math.physics.pos
TUPLE: pos pos ;

7
extra/math/physics/vel/vel.factor Normal file
View File

@ -0,0 +1,7 @@
USING: math.physics.pos ;
IN: math.physics.vel
TUPLE: vel < pos vel ;

2
extra/maze/maze.factor
View File

@ -1,7 +1,7 @@
! From http://www.ffconsultancy.com/ocaml/maze/index.html ! From http://www.ffconsultancy.com/ocaml/maze/index.html
USING: sequences namespaces math math.vectors opengl opengl.gl USING: sequences namespaces math math.vectors opengl opengl.gl
arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
math.order ; math.order math.geometry.rect ;
IN: maze IN: maze
: line-width 8 ; : line-width 8 ;

2
extra/peg/peg.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Chris Double. ! Copyright (C) 2007, 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences strings fry namespaces math assocs shuffle debugger io USING: kernel sequences strings fry namespaces math assocs shuffle debugger io
vectors arrays math.parser math.order vectors combinators combinators.lib vectors arrays math.parser math.order vectors combinators
classes sets unicode.categories compiler.units parser classes sets unicode.categories compiler.units parser
words quotations effects memoize accessors locals effects splitting words quotations effects memoize accessors locals effects splitting
combinators.short-circuit combinators.short-circuit.smart ; combinators.short-circuit combinators.short-circuit.smart ;

2
extra/processing/processing.factor
View File

@ -10,7 +10,7 @@ USING: kernel namespaces threads combinators sequences arrays
combinators.cleave combinators.cleave
rewrite-closures fry accessors newfx rewrite-closures fry accessors newfx
processing.color processing.color
processing.gadget ; processing.gadget math.geometry.rect ;
IN: processing IN: processing

71
extra/springies/springies.factor
View File

@ -1,6 +1,6 @@
USING: kernel combinators sequences arrays math math.vectors USING: kernel combinators sequences arrays math math.vectors
generalizations vars ; generalizations vars accessors math.physics.vel ;
IN: springies IN: springies
@ -28,23 +28,29 @@ VAR: gravity
! node ! node
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: node mass elas pos vel force ; ! TUPLE: node mass elas pos vel force ;
TUPLE: node < vel mass elas force ;
C: <node> node C: <node> node
: >>pos ( node pos -- node ) over set-node-pos ; ! : >>pos ( node pos -- node ) over set-node-pos ;
: >>vel ( node vel -- node ) over set-node-vel ; ! : >>vel ( node vel -- node ) over set-node-vel ;
: pos-x ( node -- x ) node-pos first ; : node-vel ( node -- vel ) vel>> ;
: pos-y ( node -- y ) node-pos second ;
: vel-x ( node -- y ) node-vel first ;
: vel-y ( node -- y ) node-vel second ;
: >>pos-x ( node x -- node ) over node-pos set-first ; : set-node-vel ( vel node -- ) swap >>vel drop ;
: >>pos-y ( node y -- node ) over node-pos set-second ;
: >>vel-x ( node x -- node ) over node-vel set-first ; : pos-x ( node -- x ) pos>> first ;
: >>vel-y ( node y -- node ) over node-vel set-second ; : pos-y ( node -- y ) pos>> second ;
: vel-x ( node -- y ) vel>> first ;
: vel-y ( node -- y ) vel>> second ;
: >>pos-x ( node x -- node ) over pos>> set-first ;
: >>pos-y ( node y -- node ) over pos>> set-second ;
: >>vel-x ( node x -- node ) over vel>> set-first ;
: >>vel-y ( node y -- node ) over vel>> set-second ;
: apply-force ( node vec -- ) over node-force v+ swap set-node-force ; : apply-force ( node vec -- ) over node-force v+ swap set-node-force ;
@ -61,7 +67,7 @@ TUPLE: spring rest-length k damp node-a node-b ;
C: <spring> spring C: <spring> spring
: end-points ( spring -- b-pos a-pos ) : end-points ( spring -- b-pos a-pos )
[ spring-node-b node-pos ] [ spring-node-a node-pos ] bi ; [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi ;
: spring-length ( spring -- length ) end-points v- norm ; : spring-length ( spring -- length ) end-points v- norm ;
@ -112,10 +118,10 @@ C: <spring> spring
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: relative-velocity-a ( spring -- vel ) : relative-velocity-a ( spring -- vel )
[ spring-node-a node-vel ] [ spring-node-b node-vel ] bi v- ; [ spring-node-a vel>> ] [ spring-node-b vel>> ] bi v- ;
: unit-vec-b->a ( spring -- vec ) : unit-vec-b->a ( spring -- vec )
[ spring-node-a node-pos ] [ spring-node-b node-pos ] bi v- ; [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi v- ;
: relative-velocity-along-spring-a ( spring -- vel ) : relative-velocity-along-spring-a ( spring -- vel )
[ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ; [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ;
@ -126,10 +132,10 @@ C: <spring> spring
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: relative-velocity-b ( spring -- vel ) : relative-velocity-b ( spring -- vel )
[ spring-node-b node-vel ] [ spring-node-a node-vel ] bi v- ; [ spring-node-b vel>> ] [ spring-node-a vel>> ] bi v- ;
: unit-vec-a->b ( spring -- vec ) : unit-vec-a->b ( spring -- vec )
[ spring-node-b node-pos ] [ spring-node-a node-pos ] bi v- ; [ spring-node-b pos>> ] [ spring-node-a pos>> ] bi v- ;
: relative-velocity-along-spring-b ( spring -- vel ) : relative-velocity-along-spring-b ( spring -- vel )
[ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ; [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ;
@ -210,9 +216,9 @@ C: <spring> spring
: calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ; : calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ;
: new-vel ( node -- vel ) : new-vel ( node -- vel )
[ node-vel ] [ calc-acceleration time-slice> v*n ] bi v+ ; [ vel>> ] [ calc-acceleration time-slice> v*n ] bi v+ ;
: new-pos ( node -- pos ) [ node-pos ] [ node-vel time-slice> v*n ] bi v+ ; : new-pos ( node -- pos ) [ pos>> ] [ vel>> time-slice> v*n ] bi v+ ;
: iterate-node ( node -- ) : iterate-node ( node -- )
dup new-pos >>pos dup new-pos >>pos
@ -231,16 +237,21 @@ C: <spring> spring
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: mass ( id x y x-vel y-vel mass elas -- ) : mass ( id x y x-vel y-vel mass elas -- )
7 nrot drop node new
6 nrot 6 nrot 2array swap >>elas
5 nrot 5 nrot 2array swap >>mass
0 0 2array <node> -rot 2array >>vel
nodes> swap suffix >nodes ; -rot 2array >>pos
0 0 2array >>force
nodes> swap suffix >nodes
drop ;
: spng ( id id-a id-b k damp rest-length -- ) : spng ( id id-a id-b k damp rest-length -- )
6 nrot drop spring new
-rot swap >>rest-length
5 nrot node-id swap >>damp
5 nrot node-id swap >>k
<spring> swap node-id >>node-b
springs> swap suffix >springs ; swap node-id >>node-a
springs> swap suffix >springs
drop ;

6
extra/springies/ui/ui.factor
View File

@ -1,16 +1,16 @@
USING: kernel namespaces threads sequences math math.vectors USING: kernel namespaces threads sequences math math.vectors
opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate
fry rewrite-closures vars springies ; fry rewrite-closures vars springies accessors math.geometry.rect ;
IN: springies.ui IN: springies.ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: draw-node ( node -- ) node-pos { -5 -5 } v+ dup { 10 10 } v+ gl-rect ; : draw-node ( node -- ) pos>> { -5 -5 } v+ dup { 10 10 } v+ gl-rect ;
: draw-spring ( spring -- ) : draw-spring ( spring -- )
[ spring-node-a node-pos ] [ spring-node-b node-pos ] bi gl-line ; [ spring-node-a pos>> ] [ spring-node-b pos>> ] bi gl-line ;
: draw-nodes ( -- ) nodes> [ draw-node ] each ; : draw-nodes ( -- ) nodes> [ draw-node ] each ;

3
extra/tetris/tetris.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels
ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui
tetris.game tetris.gl sequences system math math.parser namespaces ; tetris.game tetris.gl sequences system math math.parser namespaces
math.geometry.rect ;
IN: tetris IN: tetris
TUPLE: tetris-gadget tetris alarm ; TUPLE: tetris-gadget tetris alarm ;

2
extra/tuple-arrays/tuple-arrays-tests.factor
View File

@ -6,7 +6,7 @@ TUPLE: foo bar ;
C: <foo> foo C: <foo> foo
[ 2 ] [ 2 T{ foo } <tuple-array> dup mat set length ] unit-test [ 2 ] [ 2 T{ foo } <tuple-array> dup mat set length ] unit-test
[ T{ foo } ] [ mat get first ] unit-test [ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test [ T{ foo 2 1 } ] [ T{ foo 2 1 } 0 mat get [ set-nth ] keep first ] unit-test
[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test [ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test
[ T{ foo f 3 } t ] [ T{ foo f 3 } t ]
[ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test [ mat get [ foo-bar 2 + <foo> ] map [ first ] keep tuple-array? ] unit-test

31
extra/tuple-arrays/tuple-arrays.factor
View File

@ -1,35 +1,26 @@
! Copyright (C) 2007 Daniel Ehrenberg. ! Copyright (C) 2007 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: splitting grouping classes.tuple classes math kernel USING: splitting grouping classes.tuple classes math kernel
sequences arrays ; sequences arrays accessors ;
IN: tuple-arrays IN: tuple-arrays
TUPLE: tuple-array example ; TUPLE: tuple-array seq class ;
: prepare-example ( tuple -- seq n )
dup class over delegate [ 1array ] [ f 2array ] if
swap tuple>array length over length - ;
: <tuple-array> ( length example -- tuple-array ) : <tuple-array> ( length example -- tuple-array )
prepare-example [ rot * { } new-sequence ] keep [ tuple>array length 1- [ * { } new-sequence ] keep <sliced-groups> ]
<sliced-groups> tuple-array construct-delegate [ class ] bi tuple-array boa ;
[ set-tuple-array-example ] keep ;
: reconstruct ( seq example -- tuple )
prepend >tuple ;
M: tuple-array nth M: tuple-array nth
[ delegate nth ] keep [ seq>> nth ] [ class>> ] bi prefix >tuple ;
tuple-array-example reconstruct ;
: deconstruct ( tuple example -- seq ) : deconstruct ( tuple -- seq )
>r tuple>array r> length tail-slice ; tuple>array 1 tail ;
M: tuple-array set-nth ( elt n seq -- ) M: tuple-array set-nth ( elt n seq -- )
tuck >r >r tuple-array-example deconstruct r> r> >r >r deconstruct r> r> seq>> set-nth ;
delegate set-nth ;
M: tuple-array new-sequence tuple-array-example >tuple <tuple-array> ; M: tuple-array new-sequence
class>> new <tuple-array> ;
: >tuple-array ( seq -- tuple-array/seq ) : >tuple-array ( seq -- tuple-array/seq )
dup empty? [ dup empty? [
@ -39,4 +30,6 @@ M: tuple-array new-sequence tuple-array-example >tuple <tuple-array> ;
M: tuple-array like M: tuple-array like
drop dup tuple-array? [ >tuple-array ] unless ; drop dup tuple-array? [ >tuple-array ] unless ;
M: tuple-array length seq>> length ;
INSTANCE: tuple-array sequence INSTANCE: tuple-array sequence

2
extra/ui/cocoa/cocoa.factor
View File

@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
cocoa.windows cocoa.classes cocoa.application sequences system cocoa.windows cocoa.classes cocoa.application sequences system
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
ui.cocoa.views core-foundation threads ; ui.cocoa.views core-foundation threads math.geometry.rect ;
IN: ui.cocoa IN: ui.cocoa
TUPLE: handle view window ; TUPLE: handle view window ;

2
extra/ui/cocoa/views/views.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays assocs cocoa kernel
math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views
cocoa.application cocoa.pasteboard cocoa.types cocoa.windows cocoa.application cocoa.pasteboard cocoa.types cocoa.windows
sequences ui ui.gadgets ui.gadgets.worlds ui.gestures sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
core-foundation threads combinators ; core-foundation threads combinators math.geometry.rect ;
IN: ui.cocoa.views IN: ui.cocoa.views
: send-mouse-moved ( view event -- ) : send-mouse-moved ( view event -- )

2
extra/ui/gadgets/books/books.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences models ui.gadgets ; USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
IN: ui.gadgets.books IN: ui.gadgets.books
TUPLE: book < gadget ; TUPLE: book < gadget ;

2
extra/ui/gadgets/borders/borders.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays ui.gadgets kernel math USING: accessors arrays ui.gadgets kernel math
namespaces vectors sequences math.vectors ; namespaces vectors sequences math.vectors math.geometry.rect ;
IN: ui.gadgets.borders IN: ui.gadgets.borders
TUPLE: border < gadget TUPLE: border < gadget

2
extra/ui/gadgets/buttons/buttons.factor
View File

@ -6,7 +6,7 @@ classes.tuple opengl math.vectors
ui.commands ui.gadgets ui.gadgets.borders ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.labels ui.gadgets.theme ui.gadgets.labels ui.gadgets.theme
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
ui.render ; ui.render math.geometry.rect ;
IN: ui.gadgets.buttons IN: ui.gadgets.buttons
TUPLE: button < border pressed? selected? quot ; TUPLE: button < border pressed? selected? quot ;

3
extra/ui/gadgets/editors/editors.factor
View File

@ -5,7 +5,8 @@ namespaces opengl opengl.gl sequences strings io.styles
math.vectors sorting colors combinators assocs math.order math.vectors sorting colors combinators assocs math.order
ui.clipboards ui.commands ui.gadgets ui.gadgets.borders ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures ; ui.gadgets.theme ui.gadgets.wrappers ui.render ui.gestures
math.geometry.rect ;
IN: ui.gadgets.editors IN: ui.gadgets.editors
TUPLE: editor < gadget TUPLE: editor < gadget

2
extra/ui/gadgets/frame-buffer/frame-buffer.factor
View File

@ -1,7 +1,7 @@
USING: kernel alien.c-types combinators sequences splitting grouping USING: kernel alien.c-types combinators sequences splitting grouping
opengl.gl ui.gadgets ui.render opengl.gl ui.gadgets ui.render
math math.vectors accessors ; math math.vectors accessors math.geometry.rect ;
IN: ui.gadgets.frame-buffer IN: ui.gadgets.frame-buffer

3
extra/ui/gadgets/frames/frames.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2007 Slava Pestov. ! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays generic kernel math namespaces sequences words USING: arrays generic kernel math namespaces sequences words
splitting grouping math.vectors ui.gadgets.grids ui.gadgets ; splitting grouping math.vectors ui.gadgets.grids ui.gadgets
math.geometry.rect ;
IN: ui.gadgets.frames IN: ui.gadgets.frames
! A frame arranges gadgets in a 3x3 grid, where the center ! A frame arranges gadgets in a 3x3 grid, where the center

52
extra/ui/gadgets/gadgets-docs.factor
View File

@ -1,53 +1,7 @@
USING: help.markup help.syntax opengl kernel strings USING: help.markup help.syntax opengl kernel strings
classes.tuple classes quotations models ; classes.tuple classes quotations models math.geometry.rect ;
IN: ui.gadgets IN: ui.gadgets
HELP: rect
{ $class-description "A rectangle with the following slots:"
{ $list
{ { $link rect-loc } " - the top-left corner of the rectangle as an x/y pair" }
{ { $link rect-dim } " - the dimensions of the rectangle as a width/height pair" }
}
"Rectangles are constructed by calling " { $link <rect> } " and " { $link <extent-rect> } "."
} ;
HELP: <rect> ( loc dim -- rect )
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } { "rect" "a new " { $link rect } } }
{ $description "Creates a new rectangle with the specified top-left location and dimensions." } ;
{ <zero-rect> <rect> <extent-rect> } related-words
HELP: set-rect-dim ( dim rect -- )
{ $values { "dim" "a pair of integers" } { "rect" rect } }
{ $description "Modifies the dimensions of a rectangle. To resize a gadget, use " { $link set-gadget-dim } " or " { $link set-layout-dim } " instead." }
{ $side-effects "rect" } ;
HELP: rect-bounds
{ $values { "rect" rect } { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
{ $description "Outputs the location and dimensions of a rectangle." } ;
{ rect-bounds rect-extent } related-words
HELP: <extent-rect> ( loc ext -- rect )
{ $values { "loc" "a pair of integers" } { "ext" "a pair of integers" } { "rect" "a new " { $link rect } } }
{ $description "Creates a new rectangle with the specified top-left and bottom-right corner locations." } ;
HELP: rect-extent
{ $values { "rect" rect } { "loc" "a pair of integers" } { "ext" "a pair of integers" } }
{ $description "Outputs the location of the top-left and bottom-right corners of a rectangle." } ;
HELP: offset-rect
{ $values { "rect" rect } { "loc" "a pair of integers" } { "newrect" "a new " { $link rect } } }
{ $description "Creates a new rectangle with the same dimensions, and top-left corner translated by " { $snippet "loc" } "." } ;
HELP: rect-intersect
{ $values { "rect1" rect } { "rect2" rect } { "newrect" "a new " { $link rect } } }
{ $description "Computes the intersection of two rectangles." } ;
HELP: intersects?
{ $values { "rect/point" "a " { $link rect } " or a pair of integers" } { "rect" rect } { "?" "a boolean" } }
{ $description "Tests if two rectangles (or a point and a rectangle, respectively) have a non-empty intersection." } ;
HELP: gadget-child HELP: gadget-child
{ $values { "gadget" gadget } { "child" gadget } } { $values { "gadget" gadget } { "child" gadget } }
{ $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ; { $description "Outputs the first child of the gadget. Typically this word is used with gadgets which are known to have an only child." } ;
@ -57,10 +11,6 @@ HELP: nth-gadget
{ $description "Outputs the " { $snippet "n" } "th child of the gadget." } { $description "Outputs the " { $snippet "n" } "th child of the gadget." }
{ $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ; { $errors "Throws an error if " { $snippet "n" } " is negative or greater than or equal to the number of children." } ;
HELP: <zero-rect>
{ $values { "rect" "a new " { $link rect } } }
{ $description "Creates a rectangle located at the origin with zero dimensions." } ;
HELP: <gadget> HELP: <gadget>
{ $values { "gadget" "a new " { $link gadget } } } { $values { "gadget" "a new " { $link gadget } } }
{ $description "Creates a new gadget." } ; { $description "Creates a new gadget." } ;

41
extra/ui/gadgets/gadgets.factor
View File

@ -2,50 +2,15 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hashtables kernel models math namespaces USING: accessors arrays hashtables kernel models math namespaces
sequences quotations math.vectors combinators sorting vectors sequences quotations math.vectors combinators sorting vectors
dlists dequeues models threads concurrency.flags math.order ; dlists dequeues models threads concurrency.flags
math.order math.geometry.rect ;
IN: ui.gadgets IN: ui.gadgets
SYMBOL: ui-notify-flag SYMBOL: ui-notify-flag
: notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
: <zero-rect> ( -- rect ) rect new ;
C: <rect> rect
M: array rect-loc ;
M: array rect-dim drop { 0 0 } ;
: rect-bounds ( rect -- loc dim ) dup rect-loc swap rect-dim ;
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
: 2rect-extent ( rect rect -- loc1 loc2 ext1 ext2 )
[ rect-extent ] bi@ swapd ;
: <extent-rect> ( loc ext -- rect ) over [v-] <rect> ;
: offset-rect ( rect loc -- newrect )
over rect-loc v+ swap rect-dim <rect> ;
: (rect-intersect) ( rect rect -- array array )
2rect-extent vmin >r vmax r> ;
: rect-intersect ( rect1 rect2 -- newrect )
(rect-intersect) <extent-rect> ;
: intersects? ( rect/point rect -- ? )
(rect-intersect) [v-] { 0 0 } = ;
: (rect-union) ( rect rect -- array array )
2rect-extent vmax >r vmin r> ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;
TUPLE: gadget < rect TUPLE: gadget < rect
pref-dim parent children orientation focus pref-dim parent children orientation focus
visible? root? clipped? layout-state graft-state graft-node visible? root? clipped? layout-state graft-state graft-node

2
extra/ui/gadgets/grid-lines/grid-lines.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov. ! Copyright (C) 2006, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces opengl opengl.gl sequences USING: kernel math namespaces opengl opengl.gl sequences
math.vectors ui.gadgets ui.gadgets.grids ui.render ; math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
IN: ui.gadgets.grid-lines IN: ui.gadgets.grid-lines
TUPLE: grid-lines color ; TUPLE: grid-lines color ;

3
extra/ui/gadgets/grids/grids.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math namespaces sequences words io USING: arrays kernel math namespaces sequences words io
io.streams.string math.vectors ui.gadgets columns accessors ; io.streams.string math.vectors ui.gadgets columns accessors
math.geometry.rect ;
IN: ui.gadgets.grids IN: ui.gadgets.grids
TUPLE: grid < gadget TUPLE: grid < gadget

2
extra/ui/gadgets/incremental/incremental.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel math namespaces math.vectors ui.gadgets USING: io kernel math namespaces math.vectors ui.gadgets
ui.gadgets.packs accessors ; ui.gadgets.packs accessors math.geometry.rect ;
IN: ui.gadgets.incremental IN: ui.gadgets.incremental
! Incremental layout allows adding lines to panes to be O(1). ! Incremental layout allows adding lines to panes to be O(1).

2
extra/ui/gadgets/lists/lists.factor
View File

@ -4,7 +4,7 @@ USING: accessors ui.commands ui.gestures ui.render ui.gadgets
ui.gadgets.labels ui.gadgets.scrollers ui.gadgets.labels ui.gadgets.scrollers
kernel sequences models opengl math math.order namespaces kernel sequences models opengl math math.order namespaces
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
math.vectors classes.tuple ; math.vectors classes.tuple math.geometry.rect ;
IN: ui.gadgets.lists IN: ui.gadgets.lists
TUPLE: list < pack index presenter color hook ; TUPLE: list < pack index presenter color hook ;

3
extra/ui/gadgets/menus/menus.factor
View File

@ -3,7 +3,8 @@
USING: arrays ui.commands ui.gadgets ui.gadgets.buttons USING: arrays ui.commands ui.gadgets ui.gadgets.buttons
ui.gadgets.worlds ui.gestures generic hashtables kernel math ui.gadgets.worlds ui.gestures generic hashtables kernel math
models namespaces opengl sequences math.vectors models namespaces opengl sequences math.vectors
ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors ; ui.gadgets.theme ui.gadgets.packs ui.gadgets.borders colors
math.geometry.rect ;
IN: ui.gadgets.menus IN: ui.gadgets.menus
: menu-loc ( world menu -- loc ) : menu-loc ( world menu -- loc )

2
extra/ui/gadgets/packs/packs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences ui.gadgets kernel math math.functions USING: sequences ui.gadgets kernel math math.functions
math.vectors namespaces math.order accessors ; math.vectors namespaces math.order accessors math.geometry.rect ;
IN: ui.gadgets.packs IN: ui.gadgets.packs
TUPLE: pack < gadget TUPLE: pack < gadget

2
extra/ui/gadgets/panes/panes.factor
View File

@ -9,7 +9,7 @@ quotations math opengl combinators math.vectors
sorting splitting io.streams.nested assocs sorting splitting io.streams.nested assocs
ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids
ui.gadgets.grid-lines classes.tuple models continuations ui.gadgets.grid-lines classes.tuple models continuations
destructors accessors ; destructors accessors math.geometry.rect ;
IN: ui.gadgets.panes IN: ui.gadgets.panes
TUPLE: pane < pack TUPLE: pane < pack

2
extra/ui/gadgets/paragraphs/paragraphs.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov ! Copyright (C) 2005, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math USING: arrays ui.gadgets ui.gadgets.labels ui.render kernel math
namespaces sequences math.order ; namespaces sequences math.order math.geometry.rect ;
IN: ui.gadgets.paragraphs IN: ui.gadgets.paragraphs
! A word break gadget ! A word break gadget

2
extra/ui/gadgets/scrollers/scrollers-docs.factor
View File

@ -1,5 +1,5 @@
USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports
ui.gadgets.sliders ; ui.gadgets.sliders math.geometry.rect ;
IN: ui.gadgets.scrollers IN: ui.gadgets.scrollers
HELP: scroller HELP: scroller

2
extra/ui/gadgets/scrollers/scrollers.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays ui.gadgets ui.gadgets.viewports
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
ui.gadgets.sliders ui.gestures kernel math namespaces sequences ui.gadgets.sliders ui.gestures kernel math namespaces sequences
models models.range models.compose models models.range models.compose
combinators math.vectors classes.tuple ; combinators math.vectors classes.tuple math.geometry.rect ;
IN: ui.gadgets.scrollers IN: ui.gadgets.scrollers
TUPLE: scroller < frame viewport x y follows ; TUPLE: scroller < frame viewport x y follows ;

2
extra/ui/gadgets/sliders/sliders.factor
View File

@ -4,7 +4,7 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
ui.gadgets.frames ui.gadgets.grids math.order ui.gadgets.frames ui.gadgets.grids math.order
ui.gadgets.theme ui.render kernel math namespaces sequences ui.gadgets.theme ui.render kernel math namespaces sequences
vectors models models.range math.vectors math.functions vectors models models.range math.vectors math.functions
quotations colors ; quotations colors math.geometry.rect ;
IN: ui.gadgets.sliders IN: ui.gadgets.sliders
TUPLE: elevator < gadget direction ; TUPLE: elevator < gadget direction ;

2
extra/ui/gadgets/tabs/tabs.factor
View File

@ -51,6 +51,6 @@ DEFER: (del-page)
tabbed new-frame tabbed new-frame
[ g 0 <model> >>model [ g 0 <model> >>model
<pile> 1 >>fill [ >>toggler ] keep swap @left grid-add <pile> 1 >>fill [ >>toggler ] keep swap @left grid-add
[ keys g swap >>names ] [ keys >vector g swap >>names ]
[ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi [ values g model>> <book> [ >>content ] keep swap @center grid-add ] bi
g redo-toggler g ] with-gadget ; g redo-toggler g ] with-gadget ;

2
extra/ui/gadgets/tracks/tracks.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2008 Slava Pestov. ! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors io kernel math namespaces USING: accessors io kernel math namespaces
sequences words math.vectors ui.gadgets ui.gadgets.packs ; sequences words math.vectors ui.gadgets ui.gadgets.packs math.geometry.rect ;
IN: ui.gadgets.tracks IN: ui.gadgets.tracks
TUPLE: track < pack sizes ; TUPLE: track < pack sizes ;

2
extra/ui/gadgets/viewports/viewports.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
IN: ui.gadgets.viewports IN: ui.gadgets.viewports
USING: accessors arrays ui.gadgets ui.gadgets.borders USING: accessors arrays ui.gadgets ui.gadgets.borders
kernel math namespaces sequences models math.vectors ; kernel math namespaces sequences models math.vectors math.geometry.rect ;
: viewport-gap { 3 3 } ; inline : viewport-gap { 3 3 } ; inline

2
extra/ui/gadgets/worlds/worlds.factor
View File

@ -3,7 +3,7 @@
USING: accessors arrays assocs continuations kernel math models USING: accessors arrays assocs continuations kernel math models
namespaces opengl sequences io combinators math.vectors namespaces opengl sequences io combinators math.vectors
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
debugger ; debugger math.geometry.rect ;
IN: ui.gadgets.worlds IN: ui.gadgets.worlds
TUPLE: world < track TUPLE: world < track

2
extra/ui/render/render-docs.factor
View File

@ -1,5 +1,5 @@
USING: ui.gadgets ui.gestures help.markup help.syntax USING: ui.gadgets ui.gestures help.markup help.syntax
kernel classes strings opengl.gl models ; kernel classes strings opengl.gl models math.geometry.rect ;
IN: ui.render IN: ui.render
HELP: gadget HELP: gadget

3
extra/ui/render/render.factor
View File

@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays hashtables io kernel math namespaces opengl USING: alien arrays hashtables io kernel math namespaces opengl
opengl.gl opengl.glu sequences strings io.styles vectors opengl.gl opengl.glu sequences strings io.styles vectors
combinators math.vectors ui.gadgets colors math.order ; combinators math.vectors ui.gadgets colors
math.order math.geometry.rect ;
IN: ui.render IN: ui.render
SYMBOL: clip SYMBOL: clip

2
extra/ui/ui-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax strings quotations debugger USING: help.markup help.syntax strings quotations debugger
io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds io.styles namespaces ui.backend ui.gadgets ui.gadgets.worlds
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids ; ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids math.geometry.rect ;
IN: ui IN: ui
HELP: windows HELP: windows

2
extra/ui/windows/windows.factor
View File

@ -8,7 +8,7 @@ sequences strings vectors words windows.kernel32 windows.gdi32
windows.user32 windows.opengl32 windows.messages windows.types windows.user32 windows.opengl32 windows.messages windows.types
windows.nt windows threads libc combinators continuations windows.nt windows threads libc combinators continuations
command-line shuffle opengl ui.render unicode.case ascii command-line shuffle opengl ui.render unicode.case ascii
math.bitfields locals symbols accessors ; math.bitfields locals symbols accessors math.geometry.rect ;
IN: ui.windows IN: ui.windows
SINGLETON: windows-ui-backend SINGLETON: windows-ui-backend

2
extra/ui/x11/x11.factor
View File

@ -6,7 +6,7 @@ assocs kernel math namespaces opengl sequences strings x11.xlib
x11.events x11.xim x11.glx x11.clipboard x11.constants x11.events x11.xim x11.glx x11.clipboard x11.constants
x11.windows io.encodings.string io.encodings.ascii x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators debugger command-line qualified io.encodings.utf8 combinators debugger command-line qualified
math.vectors classes.tuple opengl.gl threads ; math.vectors classes.tuple opengl.gl threads math.geometry.rect ;
QUALIFIED: system QUALIFIED: system
IN: ui.x11 IN: ui.x11

4
vm/cpu-x86.32.S
View File

@ -6,7 +6,6 @@ and the callstack top is passed in EDX */
#define ARG0 %eax #define ARG0 %eax
#define ARG1 %edx #define ARG1 %edx
#define XT_REG %ecx
#define STACK_REG %esp #define STACK_REG %esp
#define DS_REG %esi #define DS_REG %esi
#define RETURN_REG %eax #define RETURN_REG %eax
@ -22,9 +21,6 @@ and the callstack top is passed in EDX */
pop %ebx pop %ebx
#define QUOT_XT_OFFSET 9 #define QUOT_XT_OFFSET 9
#define PROFILING_OFFSET 25
#define WORD_DEF_OFFSET 13
#define WORD_XT_OFFSET 29
/* We pass a function pointer to memcpy to work around a Mac OS X /* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative ABI limitation which would otherwise require us to do a bizzaro PC-relative

4
vm/cpu-x86.64.S
View File

@ -2,7 +2,6 @@
#define ARG0 %rdi #define ARG0 %rdi
#define ARG1 %rsi #define ARG1 %rsi
#define XT_REG %rcx
#define STACK_REG %rsp #define STACK_REG %rsp
#define DS_REG %r14 #define DS_REG %r14
#define RETURN_REG %rax #define RETURN_REG %rax
@ -22,9 +21,6 @@
pop %rbx pop %rbx
#define QUOT_XT_OFFSET 21 #define QUOT_XT_OFFSET 21
#define PROFILING_OFFSET 53
#define WORD_DEF_OFFSET 29
#define WORD_XT_OFFSET 61
/* We pass a function pointer to memcpy to work around a Mac OS X /* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative ABI limitation which would otherwise require us to do a bizzaro PC-relative

17
vm/cpu-x86.S
View File

@ -1,5 +1,3 @@
#define JUMP_QUOT jmp *QUOT_XT_OFFSET(ARG0)
DEF(F_FASTCALL void,c_to_factor,(CELL quot)): DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
PUSH_NONVOLATILE PUSH_NONVOLATILE
push ARG0 /* Save quot */ push ARG0 /* Save quot */
@ -14,20 +12,9 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
POP_NONVOLATILE POP_NONVOLATILE
ret ret
DEF(F_FASTCALL void,primitive_call,(void)):
mov (DS_REG),ARG0 /* Load quotation from data stack */
sub $CELL_SIZE,DS_REG /* Pop data stack */
JUMP_QUOT
/* Don't mess up EDX, it's the callstack top parameter to primitives. */
DEF(F_FASTCALL void,primitive_execute,(void)):
mov (DS_REG),ARG0 /* Load word from data stack */
sub $CELL_SIZE,DS_REG /* Pop data stack */
jmp *WORD_XT_OFFSET(ARG0) /* Load word-xt slot */
DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)): DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
mov ARG1,STACK_REG /* rewind_to */ mov ARG1,STACK_REG /* rewind_to */
JUMP_QUOT jmp *QUOT_XT_OFFSET(ARG0)
DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
mov STACK_REG,ARG1 /* Save stack pointer */ mov STACK_REG,ARG1 /* Save stack pointer */
@ -39,7 +26,7 @@ DEF(FASTCALL void,lazy_jit_compile,(CELL quot)):
pop ARG1 /* OK to clobber ARG1 here */ pop ARG1 /* OK to clobber ARG1 here */
pop ARG1 pop ARG1
pop ARG1 pop ARG1
JUMP_QUOT /* Call the quotation */ jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */
#ifdef WINDOWS #ifdef WINDOWS
.section .drectve .section .drectve

2
vm/layouts.h
View File

@ -129,6 +129,8 @@ typedef struct {
CELL compiledp; CELL compiledp;
/* TAGGED call count for profiling */ /* TAGGED call count for profiling */
CELL counter; CELL counter;
/* TAGGED machine code for sub-primitive */
CELL subprimitive;
/* UNTAGGED execution token: jump here to execute word */ /* UNTAGGED execution token: jump here to execute word */
XT xt; XT xt;
/* UNTAGGED compiled code block */ /* UNTAGGED compiled code block */

68
vm/math.c
View File

@ -35,33 +35,18 @@ DEFINE_PRIMITIVE(float_to_fixnum)
F_FIXNUM y = untag_fixnum_fast(dpop()); \ F_FIXNUM y = untag_fixnum_fast(dpop()); \
F_FIXNUM x = untag_fixnum_fast(dpop()); F_FIXNUM x = untag_fixnum_fast(dpop());
/* The fixnum arithmetic operations defined in C are relatively slow.
The Factor compiler has optimized assembly intrinsics for some of these
operations. */
DEFINE_PRIMITIVE(fixnum_add) DEFINE_PRIMITIVE(fixnum_add)
{ {
POP_FIXNUMS(x,y) POP_FIXNUMS(x,y)
box_signed_cell(x + y); box_signed_cell(x + y);
} }
DEFINE_PRIMITIVE(fixnum_add_fast)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x + y));
}
DEFINE_PRIMITIVE(fixnum_subtract) DEFINE_PRIMITIVE(fixnum_subtract)
{ {
POP_FIXNUMS(x,y) POP_FIXNUMS(x,y)
box_signed_cell(x - y); box_signed_cell(x - y);
} }
DEFINE_PRIMITIVE(fixnum_subtract_fast)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x - y));
}
/* Multiply two integers, and trap overflow. /* Multiply two integers, and trap overflow.
Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */ Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */
DEFINE_PRIMITIVE(fixnum_multiply) DEFINE_PRIMITIVE(fixnum_multiply)
@ -87,12 +72,6 @@ DEFINE_PRIMITIVE(fixnum_multiply)
} }
} }
DEFINE_PRIMITIVE(fixnum_multiply_fast)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x * y));
}
DEFINE_PRIMITIVE(fixnum_divint) DEFINE_PRIMITIVE(fixnum_divint)
{ {
POP_FIXNUMS(x,y) POP_FIXNUMS(x,y)
@ -112,24 +91,6 @@ DEFINE_PRIMITIVE(fixnum_mod)
dpush(tag_fixnum(x % y)); dpush(tag_fixnum(x % y));
} }
DEFINE_PRIMITIVE(fixnum_and)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x & y));
}
DEFINE_PRIMITIVE(fixnum_or)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x | y));
}
DEFINE_PRIMITIVE(fixnum_xor)
{
POP_FIXNUMS(x,y)
dpush(tag_fixnum(x ^ y));
}
/* /*
* Note the hairy overflow check. * Note the hairy overflow check.
* If we're shifting right by n bits, we won't overflow as long as none of the * If we're shifting right by n bits, we won't overflow as long as none of the
@ -172,35 +133,6 @@ DEFINE_PRIMITIVE(fixnum_shift_fast)
dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y))); dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
} }
DEFINE_PRIMITIVE(fixnum_less)
{
POP_FIXNUMS(x,y)
box_boolean(x < y);
}
DEFINE_PRIMITIVE(fixnum_lesseq)
{
POP_FIXNUMS(x,y)
box_boolean(x <= y);
}
DEFINE_PRIMITIVE(fixnum_greater)
{
POP_FIXNUMS(x,y)
box_boolean(x > y);
}
DEFINE_PRIMITIVE(fixnum_greatereq)
{
POP_FIXNUMS(x,y)
box_boolean(x >= y);
}
DEFINE_PRIMITIVE(fixnum_not)
{
drepl(tag_fixnum(~untag_fixnum_fast(dpeek())));
}
/* Bignums */ /* Bignums */
DEFINE_PRIMITIVE(fixnum_to_bignum) DEFINE_PRIMITIVE(fixnum_to_bignum)
{ {

11
vm/math.h
View File

@ -11,23 +11,12 @@ DECLARE_PRIMITIVE(float_to_fixnum);
DECLARE_PRIMITIVE(fixnum_add); DECLARE_PRIMITIVE(fixnum_add);
DECLARE_PRIMITIVE(fixnum_subtract); DECLARE_PRIMITIVE(fixnum_subtract);
DECLARE_PRIMITIVE(fixnum_add_fast);
DECLARE_PRIMITIVE(fixnum_subtract_fast);
DECLARE_PRIMITIVE(fixnum_multiply); DECLARE_PRIMITIVE(fixnum_multiply);
DECLARE_PRIMITIVE(fixnum_multiply_fast);
DECLARE_PRIMITIVE(fixnum_divint); DECLARE_PRIMITIVE(fixnum_divint);
DECLARE_PRIMITIVE(fixnum_divmod); DECLARE_PRIMITIVE(fixnum_divmod);
DECLARE_PRIMITIVE(fixnum_mod); DECLARE_PRIMITIVE(fixnum_mod);
DECLARE_PRIMITIVE(fixnum_and);
DECLARE_PRIMITIVE(fixnum_or);
DECLARE_PRIMITIVE(fixnum_xor);
DECLARE_PRIMITIVE(fixnum_shift); DECLARE_PRIMITIVE(fixnum_shift);
DECLARE_PRIMITIVE(fixnum_shift_fast); DECLARE_PRIMITIVE(fixnum_shift_fast);
DECLARE_PRIMITIVE(fixnum_less);
DECLARE_PRIMITIVE(fixnum_lesseq);
DECLARE_PRIMITIVE(fixnum_greater);
DECLARE_PRIMITIVE(fixnum_greatereq);
DECLARE_PRIMITIVE(fixnum_not);
CELL bignum_zero; CELL bignum_zero;
CELL bignum_pos_one; CELL bignum_pos_one;

34
vm/primitives.c
View File

@ -1,8 +1,6 @@
#include "master.h" #include "master.h"
void *primitives[] = { void *primitives[] = {
primitive_execute,
primitive_call,
primitive_bignum_to_fixnum, primitive_bignum_to_fixnum,
primitive_float_to_fixnum, primitive_float_to_fixnum,
primitive_fixnum_to_bignum, primitive_fixnum_to_bignum,
@ -18,24 +16,13 @@ void *primitives[] = {
primitive_bits_double, primitive_bits_double,
primitive_from_rect, primitive_from_rect,
primitive_fixnum_add, primitive_fixnum_add,
primitive_fixnum_add_fast,
primitive_fixnum_subtract, primitive_fixnum_subtract,
primitive_fixnum_subtract_fast,
primitive_fixnum_multiply, primitive_fixnum_multiply,
primitive_fixnum_multiply_fast,
primitive_fixnum_divint, primitive_fixnum_divint,
primitive_fixnum_mod, primitive_fixnum_mod,
primitive_fixnum_divmod, primitive_fixnum_divmod,
primitive_fixnum_and,
primitive_fixnum_or,
primitive_fixnum_xor,
primitive_fixnum_not,
primitive_fixnum_shift, primitive_fixnum_shift,
primitive_fixnum_shift_fast, primitive_fixnum_shift_fast,
primitive_fixnum_less,
primitive_fixnum_lesseq,
primitive_fixnum_greater,
primitive_fixnum_greatereq,
primitive_bignum_eq, primitive_bignum_eq,
primitive_bignum_add, primitive_bignum_add,
primitive_bignum_subtract, primitive_bignum_subtract,
@ -67,25 +54,6 @@ void *primitives[] = {
primitive_float_greatereq, primitive_float_greatereq,
primitive_word, primitive_word,
primitive_word_xt, primitive_word_xt,
primitive_drop,
primitive_2drop,
primitive_3drop,
primitive_dup,
primitive_2dup,
primitive_3dup,
primitive_rot,
primitive__rot,
primitive_dupd,
primitive_swapd,
primitive_nip,
primitive_2nip,
primitive_tuck,
primitive_over,
primitive_pick,
primitive_swap,
primitive_to_r,
primitive_from_r,
primitive_eq,
primitive_getenv, primitive_getenv,
primitive_setenv, primitive_setenv,
primitive_existsp, primitive_existsp,
@ -105,7 +73,6 @@ void *primitives[] = {
primitive_code_room, primitive_code_room,
primitive_os_env, primitive_os_env,
primitive_millis, primitive_millis,
primitive_tag,
primitive_modify_code_heap, primitive_modify_code_heap,
primitive_dlopen, primitive_dlopen,
primitive_dlsym, primitive_dlsym,
@ -140,7 +107,6 @@ void *primitives[] = {
primitive_set_alien_cell, primitive_set_alien_cell,
primitive_throw, primitive_throw,
primitive_alien_address, primitive_alien_address,
primitive_slot,
primitive_set_slot, primitive_set_slot,
primitive_string_nth, primitive_string_nth,
primitive_set_string_nth, primitive_set_string_nth,

194
vm/quotations.c
View File

@ -1,8 +1,38 @@
#include "master.h" #include "master.h"
/* Simple JIT compiler. This is one of the two compilers implementing Factor; /* Simple non-optimizing compiler.
the second one is written in Factor and performs a lot of optimizations.
See core/compiler/compiler.factor */ This is one of the two compilers implementing Factor; the second one is written
in Factor and performs advanced optimizations. See core/compiler/compiler.factor.
The non-optimizing compiler compiles a quotation at a time by concatenating
machine code chunks; prolog, epilog, call word, jump to word, etc. These machine
code chunks are generated from Factor code in core/cpu/.../bootstrap.factor.
It actually does do a little bit of very simple optimization:
1) Tail call optimization.
2) If a quotation is determined to not call any other words (except for a few
special words which are open-coded, see below), then no prolog/epilog is
generated.
3) When in tail position and immediately preceded by literal arguments, the
'if' and 'dispatch' conditionals are generated inline, instead of as a call to
the 'if' word.
4) When preceded by an array, calls to the 'declare' word are optimized out
entirely. This word is only used by the optimizing compiler, and with the
non-optimizing compiler it would otherwise just decrease performance to have to
push the array and immediately drop it after.
5) Sub-primitives are primitive words which are implemented in assembly and not
in the VM. They are open-coded and no subroutine call is generated. This
includes stack shufflers, some fixnum arithmetic words, and words such as tag,
slot and eq?. A primitive call is relatively expensive (two subroutine calls)
so this results in a big speedup for relatively little effort.
*/
bool jit_primitive_call_p(F_ARRAY *array, CELL i) bool jit_primitive_call_p(F_ARRAY *array, CELL i)
{ {
return (i + 2) == array_capacity(array) return (i + 2) == array_capacity(array)
@ -32,15 +62,15 @@ bool jit_ignore_declare_p(F_ARRAY *array, CELL i)
&& array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD]; && array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD];
} }
F_ARRAY *code_to_emit(CELL name) F_ARRAY *code_to_emit(CELL code)
{ {
return untag_object(array_nth(untag_object(userenv[name]),0)); return untag_object(array_nth(untag_object(code),0));
} }
F_REL rel_to_emit(CELL name, CELL code_format, CELL code_length, F_REL rel_to_emit(CELL code, CELL code_format, CELL code_length,
CELL rel_argument, bool *rel_p) CELL rel_argument, bool *rel_p)
{ {
F_ARRAY *quadruple = untag_object(userenv[name]); F_ARRAY *quadruple = untag_object(code);
CELL rel_class = array_nth(quadruple,1); CELL rel_class = array_nth(quadruple,1);
CELL rel_type = array_nth(quadruple,2); CELL rel_type = array_nth(quadruple,2);
CELL offset = array_nth(quadruple,3); CELL offset = array_nth(quadruple,3);
@ -82,22 +112,11 @@ bool jit_stack_frame_p(F_ARRAY *array)
CELL obj = array_nth(array,i); CELL obj = array_nth(array,i);
if(type_of(obj) == WORD_TYPE) if(type_of(obj) == WORD_TYPE)
{ {
if(obj != userenv[JIT_TAG_WORD] F_WORD *word = untag_object(obj);
&& obj != userenv[JIT_EQP_WORD] if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD])
&& obj != userenv[JIT_SLOT_WORD]
&& obj != userenv[JIT_DROP_WORD]
&& obj != userenv[JIT_DUP_WORD]
&& obj != userenv[JIT_TO_R_WORD]
&& obj != userenv[JIT_FROM_R_WORD]
&& obj != userenv[JIT_SWAP_WORD]
&& obj != userenv[JIT_OVER_WORD]
&& obj != userenv[JIT_FIXNUM_MINUS_WORD]
&& obj != userenv[JIT_FIXNUM_GE_WORD])
{
return true; return true;
} }
} }
}
return false; return false;
} }
@ -139,7 +158,7 @@ void jit_compile(CELL quot, bool relocate)
bool stack_frame = jit_stack_frame_p(untag_object(array)); bool stack_frame = jit_stack_frame_p(untag_object(array));
if(stack_frame) if(stack_frame)
EMIT(JIT_PROLOG,0); EMIT(userenv[JIT_PROLOG],0);
CELL i; CELL i;
CELL length = array_capacity(untag_object(array)); CELL length = array_capacity(untag_object(array));
@ -154,84 +173,44 @@ void jit_compile(CELL quot, bool relocate)
switch(type_of(obj)) switch(type_of(obj))
{ {
case WORD_TYPE: case WORD_TYPE:
word = untag_object(obj);
/* Intrinsics */ /* Intrinsics */
if(obj == userenv[JIT_TAG_WORD]) if(word->subprimitive != F)
{ {
EMIT(JIT_TAG,0); if(array_nth(untag_object(word->subprimitive),1) != F)
}
else if(obj == userenv[JIT_EQP_WORD])
{ {
GROWABLE_ARRAY_ADD(literals,T); GROWABLE_ARRAY_ADD(literals,T);
EMIT(JIT_EQP,literals_count - 1);
} }
else if(obj == userenv[JIT_SLOT_WORD])
{ EMIT(word->subprimitive,literals_count - 1);
EMIT(JIT_SLOT,0);
}
else if(obj == userenv[JIT_DROP_WORD])
{
EMIT(JIT_DROP,0);
}
else if(obj == userenv[JIT_DUP_WORD])
{
EMIT(JIT_DUP,0);
}
else if(obj == userenv[JIT_TO_R_WORD])
{
EMIT(JIT_TO_R,0);
}
else if(obj == userenv[JIT_FROM_R_WORD])
{
EMIT(JIT_FROM_R,0);
}
else if(obj == userenv[JIT_SWAP_WORD])
{
EMIT(JIT_SWAP,0);
}
else if(obj == userenv[JIT_OVER_WORD])
{
EMIT(JIT_OVER,0);
}
else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
{
EMIT(JIT_FIXNUM_MINUS,0);
}
else if(obj == userenv[JIT_FIXNUM_GE_WORD])
{
GROWABLE_ARRAY_ADD(literals,T);
EMIT(JIT_FIXNUM_GE,literals_count - 1);
} }
else else
{ {
/* Emit the epilog before the primitive call gate
so that we save the C stack pointer minus the
current stack frame. */
word = untag_object(obj);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
if(i == length - 1) if(i == length - 1)
{ {
if(stack_frame) if(stack_frame)
EMIT(JIT_EPILOG,0); EMIT(userenv[JIT_EPILOG],0);
EMIT(JIT_WORD_JUMP,literals_count - 1); EMIT(userenv[JIT_WORD_JUMP],literals_count - 1);
tail_call = true; tail_call = true;
} }
else else
EMIT(JIT_WORD_CALL,literals_count - 1); EMIT(userenv[JIT_WORD_CALL],literals_count - 1);
} }
break; break;
case WRAPPER_TYPE: case WRAPPER_TYPE:
wrapper = untag_object(obj); wrapper = untag_object(obj);
GROWABLE_ARRAY_ADD(literals,wrapper->object); GROWABLE_ARRAY_ADD(literals,wrapper->object);
EMIT(JIT_PUSH_LITERAL,literals_count - 1); EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1);
break; break;
case FIXNUM_TYPE: case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i)) if(jit_primitive_call_p(untag_object(array),i))
{ {
EMIT(JIT_PRIMITIVE,to_fixnum(obj)); EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj));
i++; i++;
@ -242,11 +221,11 @@ void jit_compile(CELL quot, bool relocate)
if(jit_fast_if_p(untag_object(array),i)) if(jit_fast_if_p(untag_object(array),i))
{ {
if(stack_frame) if(stack_frame)
EMIT(JIT_EPILOG,0); EMIT(userenv[JIT_EPILOG],0);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1)); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i + 1));
EMIT(JIT_IF_JUMP,literals_count - 2); EMIT(userenv[JIT_IF_JUMP],literals_count - 2);
i += 2; i += 2;
@ -257,10 +236,10 @@ void jit_compile(CELL quot, bool relocate)
if(jit_fast_dispatch_p(untag_object(array),i)) if(jit_fast_dispatch_p(untag_object(array),i))
{ {
if(stack_frame) if(stack_frame)
EMIT(JIT_EPILOG,0); EMIT(userenv[JIT_EPILOG],0);
GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i));
EMIT(JIT_DISPATCH,literals_count - 1); EMIT(userenv[JIT_DISPATCH],literals_count - 1);
i++; i++;
@ -274,7 +253,7 @@ void jit_compile(CELL quot, bool relocate)
} }
default: default:
GROWABLE_ARRAY_ADD(literals,obj); GROWABLE_ARRAY_ADD(literals,obj);
EMIT(JIT_PUSH_LITERAL,literals_count - 1); EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1);
break; break;
} }
} }
@ -282,9 +261,9 @@ void jit_compile(CELL quot, bool relocate)
if(!tail_call) if(!tail_call)
{ {
if(stack_frame) if(stack_frame)
EMIT(JIT_EPILOG,0); EMIT(userenv[JIT_EPILOG],0);
EMIT(JIT_RETURN,0); EMIT(userenv[JIT_RETURN],0);
} }
GROWABLE_ARRAY_TRIM(code); GROWABLE_ARRAY_TRIM(code);
@ -330,7 +309,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
bool stack_frame = jit_stack_frame_p(untag_object(array)); bool stack_frame = jit_stack_frame_p(untag_object(array));
if(stack_frame) if(stack_frame)
COUNT(JIT_PROLOG,0) COUNT(userenv[JIT_PROLOG],0)
CELL i; CELL i;
CELL length = array_capacity(untag_object(array)); CELL length = array_capacity(untag_object(array));
@ -339,55 +318,34 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
for(i = 0; i < length; i++) for(i = 0; i < length; i++)
{ {
CELL obj = array_nth(untag_object(array),i); CELL obj = array_nth(untag_object(array),i);
F_WORD *word;
switch(type_of(obj)) switch(type_of(obj))
{ {
case WORD_TYPE: case WORD_TYPE:
/* Intrinsics */ /* Intrinsics */
if(obj == userenv[JIT_TAG_WORD]) word = untag_object(obj);
COUNT(JIT_TAG,i) if(word->subprimitive != F)
else if(obj == userenv[JIT_EQP_WORD]) COUNT(word->subprimitive,i)
COUNT(JIT_EQP,i) else if(i == length - 1)
else if(obj == userenv[JIT_SLOT_WORD])
COUNT(JIT_SLOT,i)
else if(obj == userenv[JIT_DROP_WORD])
COUNT(JIT_DROP,i)
else if(obj == userenv[JIT_DUP_WORD])
COUNT(JIT_DUP,i)
else if(obj == userenv[JIT_TO_R_WORD])
COUNT(JIT_TO_R,i)
else if(obj == userenv[JIT_FROM_R_WORD])
COUNT(JIT_FROM_R,i)
else if(obj == userenv[JIT_SWAP_WORD])
COUNT(JIT_SWAP,i)
else if(obj == userenv[JIT_OVER_WORD])
COUNT(JIT_OVER,i)
else if(obj == userenv[JIT_FIXNUM_MINUS_WORD])
COUNT(JIT_FIXNUM_MINUS,i)
else if(obj == userenv[JIT_FIXNUM_GE_WORD])
COUNT(JIT_FIXNUM_GE,i)
else
{
if(i == length - 1)
{ {
if(stack_frame) if(stack_frame)
COUNT(JIT_EPILOG,i); COUNT(userenv[JIT_EPILOG],i);
COUNT(JIT_WORD_JUMP,i) COUNT(userenv[JIT_WORD_JUMP],i)
tail_call = true; tail_call = true;
} }
else else
COUNT(JIT_WORD_CALL,i) COUNT(userenv[JIT_WORD_CALL],i)
}
break; break;
case WRAPPER_TYPE: case WRAPPER_TYPE:
COUNT(JIT_PUSH_LITERAL,i) COUNT(userenv[JIT_PUSH_LITERAL],i)
break; break;
case FIXNUM_TYPE: case FIXNUM_TYPE:
if(jit_primitive_call_p(untag_object(array),i)) if(jit_primitive_call_p(untag_object(array),i))
{ {
COUNT(JIT_PRIMITIVE,i); COUNT(userenv[JIT_PRIMITIVE],i);
i++; i++;
@ -398,11 +356,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
if(jit_fast_if_p(untag_object(array),i)) if(jit_fast_if_p(untag_object(array),i))
{ {
if(stack_frame) if(stack_frame)
COUNT(JIT_EPILOG,i) COUNT(userenv[JIT_EPILOG],i)
i += 2; i += 2;
COUNT(JIT_IF_JUMP,i) COUNT(userenv[JIT_IF_JUMP],i)
tail_call = true; tail_call = true;
break; break;
@ -411,11 +369,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
if(jit_fast_dispatch_p(untag_object(array),i)) if(jit_fast_dispatch_p(untag_object(array),i))
{ {
if(stack_frame) if(stack_frame)
COUNT(JIT_EPILOG,i) COUNT(userenv[JIT_EPILOG],i)
i++; i++;
COUNT(JIT_DISPATCH,i) COUNT(userenv[JIT_DISPATCH],i)
tail_call = true; tail_call = true;
break; break;
@ -429,7 +387,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
break; break;
} }
default: default:
COUNT(JIT_PUSH_LITERAL,i) COUNT(userenv[JIT_PUSH_LITERAL],i)
break; break;
} }
} }
@ -437,9 +395,9 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
if(!tail_call) if(!tail_call)
{ {
if(stack_frame) if(stack_frame)
COUNT(JIT_EPILOG,length) COUNT(userenv[JIT_EPILOG],length)
COUNT(JIT_RETURN,length) COUNT(userenv[JIT_RETURN],length)
} }
return -1; return -1;

146
vm/run.c
View File

@ -90,133 +90,6 @@ void init_stacks(CELL ds_size_, CELL rs_size_)
stack_chain = NULL; stack_chain = NULL;
} }
DEFINE_PRIMITIVE(drop)
{
dpop();
}
DEFINE_PRIMITIVE(2drop)
{
ds -= 2 * CELLS;
}
DEFINE_PRIMITIVE(3drop)
{
ds -= 3 * CELLS;
}
DEFINE_PRIMITIVE(dup)
{
dpush(dpeek());
}
DEFINE_PRIMITIVE(2dup)
{
CELL top = dpeek();
CELL next = get(ds - CELLS);
ds += CELLS * 2;
put(ds - CELLS,next);
put(ds,top);
}
DEFINE_PRIMITIVE(3dup)
{
CELL c1 = dpeek();
CELL c2 = get(ds - CELLS);
CELL c3 = get(ds - CELLS * 2);
ds += CELLS * 3;
put (ds,c1);
put (ds - CELLS,c2);
put (ds - CELLS * 2,c3);
}
DEFINE_PRIMITIVE(rot)
{
CELL c1 = dpeek();
CELL c2 = get(ds - CELLS);
CELL c3 = get(ds - CELLS * 2);
put(ds,c3);
put(ds - CELLS,c1);
put(ds - CELLS * 2,c2);
}
DEFINE_PRIMITIVE(_rot)
{
CELL c1 = dpeek();
CELL c2 = get(ds - CELLS);
CELL c3 = get(ds - CELLS * 2);
put(ds,c2);
put(ds - CELLS,c3);
put(ds - CELLS * 2,c1);
}
DEFINE_PRIMITIVE(dupd)
{
CELL top = dpeek();
CELL next = get(ds - CELLS);
put(ds,next);
put(ds - CELLS,next);
dpush(top);
}
DEFINE_PRIMITIVE(swapd)
{
CELL top = get(ds - CELLS);
CELL next = get(ds - CELLS * 2);
put(ds - CELLS,next);
put(ds - CELLS * 2,top);
}
DEFINE_PRIMITIVE(nip)
{
CELL top = dpop();
drepl(top);
}
DEFINE_PRIMITIVE(2nip)
{
CELL top = dpeek();
ds -= CELLS * 2;
drepl(top);
}
DEFINE_PRIMITIVE(tuck)
{
CELL top = dpeek();
CELL next = get(ds - CELLS);
put(ds,next);
put(ds - CELLS,top);
dpush(top);
}
DEFINE_PRIMITIVE(over)
{
dpush(get(ds - CELLS));
}
DEFINE_PRIMITIVE(pick)
{
dpush(get(ds - CELLS * 2));
}
DEFINE_PRIMITIVE(swap)
{
CELL top = dpeek();
CELL next = get(ds - CELLS);
put(ds,next);
put(ds - CELLS,top);
}
DEFINE_PRIMITIVE(to_r)
{
rpush(dpop());
}
DEFINE_PRIMITIVE(from_r)
{
dpush(rpop());
}
bool stack_to_array(CELL bottom, CELL top) bool stack_to_array(CELL bottom, CELL top)
{ {
F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS);
@ -280,13 +153,6 @@ DEFINE_PRIMITIVE(exit)
exit(to_fixnum(dpop())); exit(to_fixnum(dpop()));
} }
DEFINE_PRIMITIVE(eq)
{
CELL lhs = dpop();
CELL rhs = dpeek();
drepl((lhs == rhs) ? T : F);
}
DEFINE_PRIMITIVE(millis) DEFINE_PRIMITIVE(millis)
{ {
box_unsigned_8(current_millis()); box_unsigned_8(current_millis());
@ -297,18 +163,6 @@ DEFINE_PRIMITIVE(sleep)
sleep_millis(to_cell(dpop())); sleep_millis(to_cell(dpop()));
} }
DEFINE_PRIMITIVE(tag)
{
drepl(tag_fixnum(TAG(dpeek())));
}
DEFINE_PRIMITIVE(slot)
{
F_FIXNUM slot = untag_fixnum_fast(dpop());
CELL obj = dpop();
dpush(get(SLOT(obj,slot)));
}
DEFINE_PRIMITIVE(set_slot) DEFINE_PRIMITIVE(set_slot)
{ {
F_FIXNUM slot = untag_fixnum_fast(dpop()); F_FIXNUM slot = untag_fixnum_fast(dpop());

24
vm/run.h
View File

@ -245,28 +245,9 @@ DLLEXPORT void save_stacks(void);
DLLEXPORT void nest_stacks(void); DLLEXPORT void nest_stacks(void);
DLLEXPORT void unnest_stacks(void); DLLEXPORT void unnest_stacks(void);
void init_stacks(CELL ds_size, CELL rs_size); void init_stacks(CELL ds_size, CELL rs_size);
DECLARE_PRIMITIVE(drop);
DECLARE_PRIMITIVE(2drop);
DECLARE_PRIMITIVE(3drop);
DECLARE_PRIMITIVE(dup);
DECLARE_PRIMITIVE(2dup);
DECLARE_PRIMITIVE(3dup);
DECLARE_PRIMITIVE(rot);
DECLARE_PRIMITIVE(_rot);
DECLARE_PRIMITIVE(dupd);
DECLARE_PRIMITIVE(swapd);
DECLARE_PRIMITIVE(nip);
DECLARE_PRIMITIVE(2nip);
DECLARE_PRIMITIVE(tuck);
DECLARE_PRIMITIVE(over);
DECLARE_PRIMITIVE(pick);
DECLARE_PRIMITIVE(swap);
DECLARE_PRIMITIVE(to_r);
DECLARE_PRIMITIVE(from_r);
DECLARE_PRIMITIVE(datastack); DECLARE_PRIMITIVE(datastack);
DECLARE_PRIMITIVE(retainstack); DECLARE_PRIMITIVE(retainstack);
DECLARE_PRIMITIVE(execute);
DECLARE_PRIMITIVE(call);
DECLARE_PRIMITIVE(getenv); DECLARE_PRIMITIVE(getenv);
DECLARE_PRIMITIVE(setenv); DECLARE_PRIMITIVE(setenv);
DECLARE_PRIMITIVE(exit); DECLARE_PRIMITIVE(exit);
@ -275,11 +256,8 @@ DECLARE_PRIMITIVE(os_envs);
DECLARE_PRIMITIVE(set_os_env); DECLARE_PRIMITIVE(set_os_env);
DECLARE_PRIMITIVE(unset_os_env); DECLARE_PRIMITIVE(unset_os_env);
DECLARE_PRIMITIVE(set_os_envs); DECLARE_PRIMITIVE(set_os_envs);
DECLARE_PRIMITIVE(eq);
DECLARE_PRIMITIVE(millis); DECLARE_PRIMITIVE(millis);
DECLARE_PRIMITIVE(sleep); DECLARE_PRIMITIVE(sleep);
DECLARE_PRIMITIVE(tag);
DECLARE_PRIMITIVE(slot);
DECLARE_PRIMITIVE(set_slot); DECLARE_PRIMITIVE(set_slot);
bool stage2; bool stage2;

1
vm/types.c
View File

@ -49,6 +49,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
word->props = F; word->props = F;
word->counter = tag_fixnum(0); word->counter = tag_fixnum(0);
word->compiledp = F; word->compiledp = F;
word->subprimitive = F;
word->profiling = NULL; word->profiling = NULL;
word->code = NULL; word->code = NULL;