From e95721ad084c0d7db9356aa779405ea214e10d1f Mon Sep 17 00:00:00 2001 From: Dan Ehrenberg Date: Fri, 11 Jul 2008 09:42:16 -0700 Subject: [PATCH 01/19] Persistent heaps --- extra/persistent-heaps/authors.txt | 1 + .../persistent-heaps-tests.factor | 11 ++ .../persistent-heaps/persistent-heaps.factor | 102 ++++++++++++++++++ extra/persistent-heaps/summary.txt | 1 + extra/persistent-heaps/tags.txt | 1 + 5 files changed, 116 insertions(+) create mode 100644 extra/persistent-heaps/authors.txt create mode 100644 extra/persistent-heaps/persistent-heaps-tests.factor create mode 100644 extra/persistent-heaps/persistent-heaps.factor create mode 100644 extra/persistent-heaps/summary.txt create mode 100644 extra/persistent-heaps/tags.txt diff --git a/extra/persistent-heaps/authors.txt b/extra/persistent-heaps/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/extra/persistent-heaps/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/extra/persistent-heaps/persistent-heaps-tests.factor b/extra/persistent-heaps/persistent-heaps-tests.factor new file mode 100644 index 0000000000..6e559971a0 --- /dev/null +++ b/extra/persistent-heaps/persistent-heaps-tests.factor @@ -0,0 +1,11 @@ +USING: persistent-heaps tools.test ; +IN: persistent-heaps.tests + +: test-input + { { "hello" 3 } { "goodbye" 2 } { "whatever" 5 } + { "foo" 1 } { "bar" -1 } { "baz" -7 } { "bing" 0 } } ; + +[ + { { "baz" -7 } { "bar" -1 } { "bing" 0 } { "foo" 1 } + { "goodbye" 2 } { "hello" 3 } { "whatever" 5 } } +] [ test-input assoc>pheap pheap>alist ] unit-test diff --git a/extra/persistent-heaps/persistent-heaps.factor b/extra/persistent-heaps/persistent-heaps.factor new file mode 100644 index 0000000000..5b57898da0 --- /dev/null +++ b/extra/persistent-heaps/persistent-heaps.factor @@ -0,0 +1,102 @@ +USING: kernel accessors multi-methods locals combinators math arrays +assocs namespaces sequences ; +IN: persistent-heaps +! These are minheaps + +> ] [ right>> ] bi [ empty-heap? ] both? ; + +C: branch +: >branch< ( branch -- value prio left right ) + { [ value>> ] [ prio>> ] [ left>> ] [ right>> ] } cleave ; +PRIVATE> + +: ( -- heap ) T{ empty-heap } ; + +: ( value prio -- heap ) + ; + +: pheap-empty? ( heap -- ? ) empty-heap? ; + +: empty-pheap ( -- * ) + "Attempt to delete from an empty heap" throw ; + +> ] [ right>> ] bi [ pheap-empty? ] both? + [ [ value>> ] [ prio>> ] bi ] + [ >branch< swap remove-left -rot [ ] 2dip rot ] if ; + +: both-with? ( obj a b quot -- ? ) + swap >r with r> swap both? ; inline + +GENERIC: sift-down ( value prio left right -- heap ) + +METHOD: sift-down { empty-heap empty-heap } ; + +METHOD: sift-down { singleton-heap empty-heap } + 3dup drop prio>> <= [ ] [ + drop -rot [ [ value>> ] [ prio>> ] bi ] 2dip + + ] if ; + +:: reroot-left ( value prio left right -- heap ) + left value>> left prio>> + value prio left left>> left right>> sift-down + right ; + +:: reroot-right ( value prio left right -- heap ) + right value>> right prio>> left + value prio right left>> right right>> sift-down + ; + +METHOD: sift-down { branch branch } + 3dup [ prio>> <= ] both-with? [ ] [ + 2dup [ prio>> ] bi@ <= [ reroot-left ] [ reroot-right ] if + ] if ; +PRIVATE> + +GENERIC: pheap-peek ( heap -- value prio ) +M: empty-heap pheap-peek empty-pheap ; +M: branch pheap-peek [ value>> ] [ prio>> ] bi ; + +GENERIC: pheap-push ( value prio heap -- newheap ) + +M: empty-heap pheap-push + drop ; + +> ] [ prio>> ] [ right>> ] tri pheap-push ] + [ left>> ] bi ; + +: push-in ( value prio heap -- newheap ) + [ 2nip [ value>> ] [ prio>> ] bi ] + [ right>> pheap-push ] + [ 2nip left>> ] 3tri ; +PRIVATE> + +M: branch pheap-push + 2dup prio>> <= [ push-top ] [ push-in ] if ; + +: pheap-pop* ( heap -- newheap ) + dup pheap-empty? [ empty-pheap ] [ + dup left>> pheap-empty? + [ drop ] + [ [ left>> remove-left ] keep right>> swap sift-down ] if + ] if ; + +: pheap-pop ( heap -- newheap value prio ) + [ pheap-pop* ] [ pheap-peek ] bi ; + +: assoc>pheap ( assoc -- heap ) ! Assoc is value => prio + swap [ rot pheap-push ] assoc-each ; + +: pheap>alist ( heap -- alist ) + [ dup pheap-empty? not ] [ pheap-pop 2array ] [ ] produce nip ; + +: pheap>values ( heap -- seq ) pheap>alist keys ; diff --git a/extra/persistent-heaps/summary.txt b/extra/persistent-heaps/summary.txt new file mode 100644 index 0000000000..1451439c65 --- /dev/null +++ b/extra/persistent-heaps/summary.txt @@ -0,0 +1 @@ +Datastructure for functional peristent heaps, from ML for the Working Programmer diff --git a/extra/persistent-heaps/tags.txt b/extra/persistent-heaps/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/extra/persistent-heaps/tags.txt @@ -0,0 +1 @@ +collections From 01714ae37f94f02cd14f41db160eb064f164cf8d Mon Sep 17 00:00:00 2001 From: Dan Ehrenberg Date: Fri, 11 Jul 2008 10:37:51 -0700 Subject: [PATCH 02/19] Persistent heaps documentation --- .../persistent-heaps-docs.factor | 58 +++++++++++++++++++ 1 file changed, 58 insertions(+) create mode 100644 extra/persistent-heaps/persistent-heaps-docs.factor diff --git a/extra/persistent-heaps/persistent-heaps-docs.factor b/extra/persistent-heaps/persistent-heaps-docs.factor new file mode 100644 index 0000000000..d538fe88d4 --- /dev/null +++ b/extra/persistent-heaps/persistent-heaps-docs.factor @@ -0,0 +1,58 @@ +USING: help.syntax help.markup kernel arrays assocs ; +IN: persistent-heaps + +HELP: +{ $values { "heap" "a persistent heap" } } +{ $description "Creates a new persistent heap" } ; + +HELP: +{ $values { "value" object } { "prio" "a priority" } { "heap" "a persistent heap" } } +{ $description "Creates a new persistent heap consisting of one object with the given priority." } ; + +HELP: pheap-empty? +{ $values { "heap" "a persistent heap" } { "?" "a boolean" } } +{ $description "Returns true if this is an empty persistent heap." } ; + +HELP: pheap-peek +{ $values { "heap" "a persistent heap" } { "value" "an object in the heap" } { "prio" "the minimum priority" } } +{ $description "Gets the object in the heap with minumum priority." } ; + +HELP: pheap-push +{ $values { "heap" "a persistent heap" } { "value" object } { "prio" "a priority" } { "newheap" "a new persistent heap" } } +{ $description "Creates a new persistent heap also containing the given object of the given priority." } ; + +HELP: pheap-pop* +{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } } +{ $description "Creates a new persistent heap with the minimum element removed." } ; + +HELP: pheap-pop +{ $values { "heap" "a persistent heap" } { "newheap" "a new persistent heap" } { "value" object } { "prio" "a priority" } } +{ $description "Creates a new persistent heap with the minimum element removed, returning that element and its priority." } ; + +HELP: assoc>pheap +{ $values { "assoc" assoc } { "heap" "a persistent heap" } } +{ $description "Creates a new persistent heap from an associative mapping whose keys are the entries in the heap and whose values are the associated priorities." } ; + +HELP: pheap>alist +{ $values { "heap" "a persistent heap" } { "alist" "an association list" } } +{ $description "Creates an association list whose keys are the entries in the heap and whose values are the associated priorities. It is in sorted order by priority. This does not modify the heap." } ; + +HELP: pheap>values +{ $values { "heap" "a persistent heap" } { "values" array } } +{ $description "Creates an an array of all of the values in the heap, in sorted order by priority. This does not modify the heap." } ; + +ARTICLE: "persistent-heaps" "Persistent heaps" +"This vocabulary implements persistent minheaps, aka priority queues. They are purely functional and support efficient O(log n) operations of pushing and popping, with O(1) time access to the minimum element. To create heaps, use the following words:" +{ $subsection } +{ $subsection } +"To manipulate them:" +{ $subsection pheap-peek } +{ $subsection pheap-push } +{ $subsection pheap-pop } +{ $subsection pheap-pop* } +{ $subsection pheap-empty? } +{ $subsection assoc>pheap } +{ $subsection pheap>alist } +{ $subsection pheap>values } ; + +ABOUT: "persistent-heaps" From 45715f52a8b875ec66e9622c01b2178e49259015 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Fri, 11 Jul 2008 16:31:35 -0400 Subject: [PATCH 03/19] Fixed bug in ui.gadgets.tabs, irc.ui no longer uses delegation --- extra/irc/ui/ui.factor | 4 ++-- extra/ui/gadgets/tabs/tabs.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index ef2bfd3d55..cc138dad92 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -82,10 +82,10 @@ M: irc-message write-irc [ swap display ] keep ; -TUPLE: irc-editor outstream listener client ; +TUPLE: irc-editor < editor outstream listener client ; : ( pane listener client -- editor ) - [ irc-editor construct-editor + [ irc-editor new-editor swap >>listener swap >>outstream ] dip client>> >>client ; diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor index 1b4f633609..7c663f88e3 100755 --- a/extra/ui/gadgets/tabs/tabs.factor +++ b/extra/ui/gadgets/tabs/tabs.factor @@ -51,6 +51,6 @@ DEFER: (del-page) tabbed new-frame [ g 0 >>model 1 >>fill [ >>toggler ] keep swap @left grid-add - [ keys g swap >>names ] + [ keys >vector g swap >>names ] [ values g model>> [ >>content ] keep swap @center grid-add ] bi g redo-toggler g ] with-gadget ; From a876005c98cd78bb49da934eb1d3b1140b8d0072 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 17:25:46 -0500 Subject: [PATCH 04/19] Clean up non optimizing compiler, rewrite more primitives in assembly --- core/bootstrap/image/image.factor | 101 ++------ core/bootstrap/primitives.factor | 80 ++++--- core/compiler/constants/constants.factor | 4 +- core/cpu/x86/bootstrap.factor | 220 ++++++++++++++---- core/inference/known-words/known-words.factor | 4 + core/words/words.factor | 4 +- vm/cpu-x86.32.S | 4 - vm/cpu-x86.64.S | 4 - vm/cpu-x86.S | 17 +- vm/layouts.h | 2 + vm/math.c | 68 ------ vm/math.h | 11 - vm/primitives.c | 34 --- vm/quotations.c | 174 ++++---------- vm/run.c | 146 ------------ vm/run.h | 24 +- vm/types.c | 1 + 17 files changed, 306 insertions(+), 592 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 62130cb179..632938bb2d 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -85,8 +85,16 @@ SYMBOL: objects : 1-offset 8 ; 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 -- ) - >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 SYMBOL: image @@ -118,29 +126,7 @@ SYMBOL: jit-dispatch SYMBOL: jit-epilog SYMBOL: jit-return 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-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 SYMBOL: undefined-quot @@ -163,29 +149,7 @@ SYMBOL: undefined-quot { jit-epilog 33 } { jit-return 34 } { 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-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 } } at header-size + ; @@ -305,6 +269,9 @@ M: f ' ! Words +: word-sub-primitive ( word -- obj ) + global [ target-word ] bind sub-primitives get at ; + : emit-word ( word -- ) [ [ subwords [ emit-word ] each ] @@ -316,12 +283,13 @@ M: f ' [ vocabulary>> , ] [ def>> , ] [ props>> , ] + [ drop f , ] + [ drop 0 , ] ! count + [ word-sub-primitive , ] + [ drop 0 , ] ! xt + [ drop 0 , ] ! code + [ drop 0 , ] ! profiling } cleave - f , - 0 , ! count - 0 , ! xt - 0 , ! code - 0 , ! profiling ] { } make [ ' ] map ] bi \ word type-number object tag-number @@ -460,18 +428,7 @@ M: quotation ' \ if jit-if-word set \ dispatch jit-dispatch-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 - \ 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 { jit-code-format @@ -488,29 +445,7 @@ M: quotation ' jit-epilog jit-return jit-profiling - jit-tag - jit-tag-word - jit-eq? - jit-eq?-word - jit-slot - jit-slot-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 } [ emit-userenv ] each ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6498dfde60..d748e063c2 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -13,6 +13,8 @@ IN: bootstrap.primitives crossref off +H{ } clone sub-primitives set + "resource:core/bootstrap/syntax.factor" parse-file "resource:core/cpu/" architecture get { @@ -256,6 +258,7 @@ bi "props" { "compiled" read-only } { "counter" { "fixnum" "math" } } + { "sub-primitive" read-only } } define-builtin "byte-array" "byte-arrays" create { } define-builtin @@ -323,14 +326,55 @@ tuple [ tuple-layout [ ] curry ] tri (( 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 : make-primitive ( word vocab n -- ) >r create dup reset-word r> [ do-primitive ] curry [ ] like define ; { - { "(execute)" "words.private" } - { "(call)" "kernel.private" } { "bignum>fixnum" "math.private" } { "float>fixnum" "math.private" } { "fixnum>bignum" "math.private" } @@ -346,24 +390,13 @@ tuple { "bits>double" "math" } { "" "math.private" } { "fixnum+" "math.private" } - { "fixnum+fast" "math.private" } { "fixnum-" "math.private" } - { "fixnum-fast" "math.private" } { "fixnum*" "math.private" } - { "fixnum*fast" "math.private" } { "fixnum/i" "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-fast" "math.private" } - { "fixnum<" "math.private" } - { "fixnum<=" "math.private" } - { "fixnum>" "math.private" } - { "fixnum>=" "math.private" } { "bignum=" "math.private" } { "bignum+" "math.private" } { "bignum-" "math.private" } @@ -395,25 +428,6 @@ tuple { "float>=" "math.private" } { "" "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" } { "setenv" "kernel.private" } { "(exists?)" "io.files.private" } @@ -433,7 +447,6 @@ tuple { "code-room" "memory" } { "os-env" "system" } { "millis" "system" } - { "tag" "kernel.private" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } { "dlsym" "alien" } @@ -468,7 +481,6 @@ tuple { "set-alien-cell" "alien.accessors" } { "(throw)" "kernel.private" } { "alien-address" "alien" } - { "slot" "slots.private" } { "set-slot" "slots.private" } { "string-nth" "strings.private" } { "set-string-nth" "strings.private" } diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 622c63d7f0..80f0b4f515 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -18,8 +18,8 @@ IN: compiler.constants : underlying-alien-offset ( -- n ) bootstrap-cell object tag-number - ; : tuple-class-offset ( -- n ) bootstrap-cell tuple 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 - ; -: 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 - ; : compiled-header-size ( -- n ) 4 bootstrap-cells ; diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index bf176eebfa..bd90ca65f0 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: bootstrap.image.private kernel namespaces system -cpu.x86.assembler layouts compiler.units math generator.fixup -compiler.constants vocabs ; +USING: bootstrap.image.private kernel kernel.private namespaces +system cpu.x86.assembler layouts compiler.units math math.private +generator.fixup compiler.constants vocabs slots.private words +words.private ; IN: bootstrap.x86 big-endian off @@ -74,27 +75,34 @@ big-endian off arg0 quot-xt-offset [+] JMP ! execute branch ] 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 tag-mask get AND ! compute tag arg1 tag-bits get SHL ! tag the tag ds-reg [] arg1 MOV ! push to stack -] f f f jit-tag jit-define - -: 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 +] f f f \ tag define-sub-primitive [ arg0 ds-reg [] MOV ! load slot number @@ -105,63 +113,187 @@ big-endian off arg1 tag-bits get SHL arg0 arg1 arg0 [+] MOV ! load slot value 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 -] 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 ds-reg bootstrap-cell ADD 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 ds-reg bootstrap-cell SUB - rs-reg [] arg0 MOV -] f f f jit->r jit-define + ds-reg [] arg0 MOV +] f f f \ nip define-sub-primitive [ - ds-reg bootstrap-cell ADD - arg0 rs-reg [] MOV - rs-reg bootstrap-cell SUB + arg0 ds-reg [] MOV + ds-reg 2 bootstrap-cells SUB 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 arg1 ds-reg bootstrap-cell neg [+] MOV ds-reg bootstrap-cell neg [+] arg0 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 - ds-reg bootstrap-cell ADD - ds-reg [] arg0 MOV -] f f f jit-over jit-define + arg0 ds-reg -1 bootstrap-cells [+] MOV + arg1 ds-reg -2 bootstrap-cells [+] MOV + ds-reg -2 bootstrap-cells [+] arg0 MOV + ds-reg -1 bootstrap-cells [+] arg1 MOV +] f f f \ swapd define-sub-primitive [ arg0 ds-reg [] MOV - ds-reg bootstrap-cell SUB - arg1 ds-reg [] MOV - arg1 arg0 SUB + arg1 ds-reg -1 bootstrap-cells [+] MOV + temp-reg ds-reg -2 bootstrap-cells [+] MOV + 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 -] f f f jit-fixnum-fast jit-define +] f f f \ -rot define-sub-primitive [ - jit-compare - arg1 temp-reg CMOVL ! not equal? + rs-reg bootstrap-cell ADD + 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 -] 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 -] f f f jit-epilog jit-define + arg0 ds-reg [] MOV ! load second input + 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 diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index ac79cce799..6f5277bc35 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -104,6 +104,8 @@ M: object infer-call ] if ] "infer" set-word-prop +\ execute t "no-compile" set-word-prop + \ if [ 3 ensure-values 2 d-tail [ special? ] contains? [ @@ -123,6 +125,8 @@ M: object infer-call [ #dispatch ] infer-branches ] "infer" set-word-prop +\ dispatch t "no-compile" set-word-prop + \ curry [ 2 ensure-values pop-d pop-d swap push-d diff --git a/core/words/words.factor b/core/words/words.factor index 9bf006fa16..1d84acbc14 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -34,7 +34,9 @@ M: symbol definer drop \ SYMBOL: f ; M: symbol definition drop f ; 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 definition drop f ; diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 6233b4a14f..b1a3561974 100644 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -6,7 +6,6 @@ and the callstack top is passed in EDX */ #define ARG0 %eax #define ARG1 %edx -#define XT_REG %ecx #define STACK_REG %esp #define DS_REG %esi #define RETURN_REG %eax @@ -22,9 +21,6 @@ and the callstack top is passed in EDX */ pop %ebx #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 ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 4e8faa18de..57bfcee87b 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -2,7 +2,6 @@ #define ARG0 %rdi #define ARG1 %rsi -#define XT_REG %rcx #define STACK_REG %rsp #define DS_REG %r14 #define RETURN_REG %rax @@ -22,9 +21,6 @@ pop %rbx #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 ABI limitation which would otherwise require us to do a bizzaro PC-relative diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 5c0a105a55..e8e2af7b25 100755 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -1,5 +1,3 @@ -#define JUMP_QUOT jmp *QUOT_XT_OFFSET(ARG0) - DEF(F_FASTCALL void,c_to_factor,(CELL quot)): PUSH_NONVOLATILE push ARG0 /* Save quot */ @@ -14,20 +12,9 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)): POP_NONVOLATILE 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)): mov ARG1,STACK_REG /* rewind_to */ - JUMP_QUOT + jmp *QUOT_XT_OFFSET(ARG0) DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): 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 pop ARG1 - JUMP_QUOT /* Call the quotation */ + jmp *QUOT_XT_OFFSET(ARG0) /* Call the quotation */ #ifdef WINDOWS .section .drectve diff --git a/vm/layouts.h b/vm/layouts.h index 06a37672a7..7ebfe50dd4 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -129,6 +129,8 @@ typedef struct { CELL compiledp; /* TAGGED call count for profiling */ CELL counter; + /* TAGGED machine code for sub-primitive */ + CELL subprimitive; /* UNTAGGED execution token: jump here to execute word */ XT xt; /* UNTAGGED compiled code block */ diff --git a/vm/math.c b/vm/math.c index 8c4e7d537a..c1e13951dc 100644 --- a/vm/math.c +++ b/vm/math.c @@ -35,33 +35,18 @@ DEFINE_PRIMITIVE(float_to_fixnum) F_FIXNUM y = 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) { POP_FIXNUMS(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) { POP_FIXNUMS(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. Thanks to David Blaikie (The_Vulture from freenode #java) for the hint. */ 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) { POP_FIXNUMS(x,y) @@ -112,24 +91,6 @@ DEFINE_PRIMITIVE(fixnum_mod) 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. * 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))); } -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 */ DEFINE_PRIMITIVE(fixnum_to_bignum) { diff --git a/vm/math.h b/vm/math.h index d82a373571..6f81ece8a8 100644 --- a/vm/math.h +++ b/vm/math.h @@ -11,23 +11,12 @@ DECLARE_PRIMITIVE(float_to_fixnum); DECLARE_PRIMITIVE(fixnum_add); DECLARE_PRIMITIVE(fixnum_subtract); -DECLARE_PRIMITIVE(fixnum_add_fast); -DECLARE_PRIMITIVE(fixnum_subtract_fast); DECLARE_PRIMITIVE(fixnum_multiply); -DECLARE_PRIMITIVE(fixnum_multiply_fast); DECLARE_PRIMITIVE(fixnum_divint); DECLARE_PRIMITIVE(fixnum_divmod); DECLARE_PRIMITIVE(fixnum_mod); -DECLARE_PRIMITIVE(fixnum_and); -DECLARE_PRIMITIVE(fixnum_or); -DECLARE_PRIMITIVE(fixnum_xor); DECLARE_PRIMITIVE(fixnum_shift); 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_pos_one; diff --git a/vm/primitives.c b/vm/primitives.c index d670b41897..b5d9403342 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -1,8 +1,6 @@ #include "master.h" void *primitives[] = { - primitive_execute, - primitive_call, primitive_bignum_to_fixnum, primitive_float_to_fixnum, primitive_fixnum_to_bignum, @@ -18,24 +16,13 @@ void *primitives[] = { primitive_bits_double, primitive_from_rect, primitive_fixnum_add, - primitive_fixnum_add_fast, primitive_fixnum_subtract, - primitive_fixnum_subtract_fast, primitive_fixnum_multiply, - primitive_fixnum_multiply_fast, primitive_fixnum_divint, primitive_fixnum_mod, primitive_fixnum_divmod, - primitive_fixnum_and, - primitive_fixnum_or, - primitive_fixnum_xor, - primitive_fixnum_not, primitive_fixnum_shift, primitive_fixnum_shift_fast, - primitive_fixnum_less, - primitive_fixnum_lesseq, - primitive_fixnum_greater, - primitive_fixnum_greatereq, primitive_bignum_eq, primitive_bignum_add, primitive_bignum_subtract, @@ -67,25 +54,6 @@ void *primitives[] = { primitive_float_greatereq, primitive_word, 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_setenv, primitive_existsp, @@ -105,7 +73,6 @@ void *primitives[] = { primitive_code_room, primitive_os_env, primitive_millis, - primitive_tag, primitive_modify_code_heap, primitive_dlopen, primitive_dlsym, @@ -140,7 +107,6 @@ void *primitives[] = { primitive_set_alien_cell, primitive_throw, primitive_alien_address, - primitive_slot, primitive_set_slot, primitive_string_nth, primitive_set_string_nth, diff --git a/vm/quotations.c b/vm/quotations.c index 7eab41688a..40e82446fd 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -32,15 +32,15 @@ bool jit_ignore_declare_p(F_ARRAY *array, CELL i) && 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) { - F_ARRAY *quadruple = untag_object(userenv[name]); + F_ARRAY *quadruple = untag_object(code); CELL rel_class = array_nth(quadruple,1); CELL rel_type = array_nth(quadruple,2); CELL offset = array_nth(quadruple,3); @@ -82,20 +82,9 @@ bool jit_stack_frame_p(F_ARRAY *array) CELL obj = array_nth(array,i); if(type_of(obj) == WORD_TYPE) { - if(obj != userenv[JIT_TAG_WORD] - && obj != userenv[JIT_EQP_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]) - { + F_WORD *word = untag_object(obj); + if(word->subprimitive == F && obj != userenv[JIT_DECLARE_WORD]) return true; - } } } @@ -139,7 +128,7 @@ void jit_compile(CELL quot, bool relocate) bool stack_frame = jit_stack_frame_p(untag_object(array)); if(stack_frame) - EMIT(JIT_PROLOG,0); + EMIT(userenv[JIT_PROLOG],0); CELL i; CELL length = array_capacity(untag_object(array)); @@ -154,84 +143,44 @@ void jit_compile(CELL quot, bool relocate) switch(type_of(obj)) { case WORD_TYPE: + word = untag_object(obj); + /* Intrinsics */ - if(obj == userenv[JIT_TAG_WORD]) + if(word->subprimitive != F) { - EMIT(JIT_TAG,0); - } - else if(obj == userenv[JIT_EQP_WORD]) - { - GROWABLE_ARRAY_ADD(literals,T); - EMIT(JIT_EQP,literals_count - 1); - } - else if(obj == userenv[JIT_SLOT_WORD]) - { - 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); + if(array_nth(untag_object(word->subprimitive),1) != F) + { + GROWABLE_ARRAY_ADD(literals,T); + } + + EMIT(word->subprimitive,literals_count - 1); } 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)); if(i == length - 1) { 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; } else - EMIT(JIT_WORD_CALL,literals_count - 1); + EMIT(userenv[JIT_WORD_CALL],literals_count - 1); } break; case WRAPPER_TYPE: wrapper = untag_object(obj); GROWABLE_ARRAY_ADD(literals,wrapper->object); - EMIT(JIT_PUSH_LITERAL,literals_count - 1); + EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1); break; case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { - EMIT(JIT_PRIMITIVE,to_fixnum(obj)); + EMIT(userenv[JIT_PRIMITIVE],to_fixnum(obj)); i++; @@ -242,11 +191,11 @@ void jit_compile(CELL quot, bool relocate) if(jit_fast_if_p(untag_object(array),i)) { 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 + 1)); - EMIT(JIT_IF_JUMP,literals_count - 2); + EMIT(userenv[JIT_IF_JUMP],literals_count - 2); i += 2; @@ -257,10 +206,10 @@ void jit_compile(CELL quot, bool relocate) if(jit_fast_dispatch_p(untag_object(array),i)) { if(stack_frame) - EMIT(JIT_EPILOG,0); + EMIT(userenv[JIT_EPILOG],0); GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - EMIT(JIT_DISPATCH,literals_count - 1); + EMIT(userenv[JIT_DISPATCH],literals_count - 1); i++; @@ -274,7 +223,7 @@ void jit_compile(CELL quot, bool relocate) } default: GROWABLE_ARRAY_ADD(literals,obj); - EMIT(JIT_PUSH_LITERAL,literals_count - 1); + EMIT(userenv[JIT_PUSH_LITERAL],literals_count - 1); break; } } @@ -282,9 +231,9 @@ void jit_compile(CELL quot, bool relocate) if(!tail_call) { 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); @@ -330,7 +279,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) bool stack_frame = jit_stack_frame_p(untag_object(array)); if(stack_frame) - COUNT(JIT_PROLOG,0) + COUNT(userenv[JIT_PROLOG],0) CELL i; CELL length = array_capacity(untag_object(array)); @@ -339,55 +288,34 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) for(i = 0; i < length; i++) { CELL obj = array_nth(untag_object(array),i); + F_WORD *word; switch(type_of(obj)) { case WORD_TYPE: /* Intrinsics */ - if(obj == userenv[JIT_TAG_WORD]) - COUNT(JIT_TAG,i) - else if(obj == userenv[JIT_EQP_WORD]) - COUNT(JIT_EQP,i) - 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 + word = untag_object(obj); + if(word->subprimitive != F) + COUNT(word->subprimitive,i) + else if(i == length - 1) { - if(i == length - 1) - { - if(stack_frame) - COUNT(JIT_EPILOG,i); - - COUNT(JIT_WORD_JUMP,i) - - tail_call = true; - } - else - COUNT(JIT_WORD_CALL,i) + if(stack_frame) + COUNT(userenv[JIT_EPILOG],i); + + COUNT(userenv[JIT_WORD_JUMP],i) + + tail_call = true; } + else + COUNT(userenv[JIT_WORD_CALL],i) break; case WRAPPER_TYPE: - COUNT(JIT_PUSH_LITERAL,i) + COUNT(userenv[JIT_PUSH_LITERAL],i) break; case FIXNUM_TYPE: if(jit_primitive_call_p(untag_object(array),i)) { - COUNT(JIT_PRIMITIVE,i); + COUNT(userenv[JIT_PRIMITIVE],i); i++; @@ -398,11 +326,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) if(jit_fast_if_p(untag_object(array),i)) { if(stack_frame) - COUNT(JIT_EPILOG,i) + COUNT(userenv[JIT_EPILOG],i) i += 2; - COUNT(JIT_IF_JUMP,i) + COUNT(userenv[JIT_IF_JUMP],i) tail_call = true; break; @@ -411,11 +339,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) if(jit_fast_dispatch_p(untag_object(array),i)) { if(stack_frame) - COUNT(JIT_EPILOG,i) + COUNT(userenv[JIT_EPILOG],i) i++; - COUNT(JIT_DISPATCH,i) + COUNT(userenv[JIT_DISPATCH],i) tail_call = true; break; @@ -429,7 +357,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) break; } default: - COUNT(JIT_PUSH_LITERAL,i) + COUNT(userenv[JIT_PUSH_LITERAL],i) break; } } @@ -437,9 +365,9 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) if(!tail_call) { if(stack_frame) - COUNT(JIT_EPILOG,length) + COUNT(userenv[JIT_EPILOG],length) - COUNT(JIT_RETURN,length) + COUNT(userenv[JIT_RETURN],length) } return -1; diff --git a/vm/run.c b/vm/run.c index ae0c91d9e6..c4a3e115c1 100755 --- a/vm/run.c +++ b/vm/run.c @@ -90,133 +90,6 @@ void init_stacks(CELL ds_size_, CELL rs_size_) 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) { F_FIXNUM depth = (F_FIXNUM)(top - bottom + CELLS); @@ -280,13 +153,6 @@ DEFINE_PRIMITIVE(exit) exit(to_fixnum(dpop())); } -DEFINE_PRIMITIVE(eq) -{ - CELL lhs = dpop(); - CELL rhs = dpeek(); - drepl((lhs == rhs) ? T : F); -} - DEFINE_PRIMITIVE(millis) { box_unsigned_8(current_millis()); @@ -297,18 +163,6 @@ DEFINE_PRIMITIVE(sleep) 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) { F_FIXNUM slot = untag_fixnum_fast(dpop()); diff --git a/vm/run.h b/vm/run.h index b54640ec8a..8a03049b93 100755 --- a/vm/run.h +++ b/vm/run.h @@ -245,28 +245,9 @@ DLLEXPORT void save_stacks(void); DLLEXPORT void nest_stacks(void); DLLEXPORT void unnest_stacks(void); 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(retainstack); -DECLARE_PRIMITIVE(execute); -DECLARE_PRIMITIVE(call); DECLARE_PRIMITIVE(getenv); DECLARE_PRIMITIVE(setenv); DECLARE_PRIMITIVE(exit); @@ -275,11 +256,8 @@ DECLARE_PRIMITIVE(os_envs); DECLARE_PRIMITIVE(set_os_env); DECLARE_PRIMITIVE(unset_os_env); DECLARE_PRIMITIVE(set_os_envs); -DECLARE_PRIMITIVE(eq); DECLARE_PRIMITIVE(millis); DECLARE_PRIMITIVE(sleep); -DECLARE_PRIMITIVE(tag); -DECLARE_PRIMITIVE(slot); DECLARE_PRIMITIVE(set_slot); bool stage2; diff --git a/vm/types.c b/vm/types.c index 3941f13042..59581ecee5 100755 --- a/vm/types.c +++ b/vm/types.c @@ -49,6 +49,7 @@ F_WORD *allot_word(CELL vocab, CELL name) word->props = F; word->counter = tag_fixnum(0); word->compiledp = F; + word->subprimitive = F; word->profiling = NULL; word->code = NULL; From f7c69e0018dfb87665d9e2284d1c37e5b0bf6ba2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 17:27:47 -0500 Subject: [PATCH 05/19] peg doesn't need combinators.lib --- extra/peg/peg.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 147e5b892e..cee0493459 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Chris Double. ! See http://factorcode.org/license.txt for BSD license. 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 words quotations effects memoize accessors locals effects splitting combinators.short-circuit combinators.short-circuit.smart ; From 380891943c179b84b346ead6d01c632d0218ba55 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Jul 2008 17:38:53 -0500 Subject: [PATCH 06/19] Better comments --- vm/quotations.c | 36 +++++++++++++++++++++++++++++++++--- 1 file changed, 33 insertions(+), 3 deletions(-) diff --git a/vm/quotations.c b/vm/quotations.c index 40e82446fd..2d54f23a6f 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -1,8 +1,38 @@ #include "master.h" -/* Simple JIT compiler. This is one of the two compilers implementing Factor; -the second one is written in Factor and performs a lot of optimizations. -See core/compiler/compiler.factor */ +/* Simple non-optimizing compiler. + +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) { return (i + 2) == array_capacity(array) From 1e829b18e5ab09dec2173ce2bd36baa31e22a252 Mon Sep 17 00:00:00 2001 From: Dan Ehrenberg Date: Sat, 12 Jul 2008 14:56:51 -0700 Subject: [PATCH 07/19] Delegate removed from tuple arrays --- extra/tuple-arrays/tuple-arrays-tests.factor | 2 +- extra/tuple-arrays/tuple-arrays.factor | 31 ++++++++------------ 2 files changed, 13 insertions(+), 20 deletions(-) diff --git a/extra/tuple-arrays/tuple-arrays-tests.factor b/extra/tuple-arrays/tuple-arrays-tests.factor index dd9510405f..132a11f4a6 100755 --- a/extra/tuple-arrays/tuple-arrays-tests.factor +++ b/extra/tuple-arrays/tuple-arrays-tests.factor @@ -6,7 +6,7 @@ TUPLE: foo bar ; C: foo [ 2 ] [ 2 T{ foo } dup mat set length ] 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{ foo f 3 } t ] [ mat get [ foo-bar 2 + ] map [ first ] keep tuple-array? ] unit-test diff --git a/extra/tuple-arrays/tuple-arrays.factor b/extra/tuple-arrays/tuple-arrays.factor index 6a31dac808..63e7541c95 100644 --- a/extra/tuple-arrays/tuple-arrays.factor +++ b/extra/tuple-arrays/tuple-arrays.factor @@ -1,35 +1,26 @@ ! Copyright (C) 2007 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: splitting grouping classes.tuple classes math kernel -sequences arrays ; +sequences arrays accessors ; IN: tuple-arrays -TUPLE: tuple-array example ; - -: prepare-example ( tuple -- seq n ) - dup class over delegate [ 1array ] [ f 2array ] if - swap tuple>array length over length - ; +TUPLE: tuple-array seq class ; : ( length example -- tuple-array ) - prepare-example [ rot * { } new-sequence ] keep - tuple-array construct-delegate - [ set-tuple-array-example ] keep ; - -: reconstruct ( seq example -- tuple ) - prepend >tuple ; + [ tuple>array length 1- [ * { } new-sequence ] keep ] + [ class ] bi tuple-array boa ; M: tuple-array nth - [ delegate nth ] keep - tuple-array-example reconstruct ; + [ seq>> nth ] [ class>> ] bi prefix >tuple ; -: deconstruct ( tuple example -- seq ) - >r tuple>array r> length tail-slice ; +: deconstruct ( tuple -- seq ) + tuple>array 1 tail ; M: tuple-array set-nth ( elt n seq -- ) - tuck >r >r tuple-array-example deconstruct r> r> - delegate set-nth ; + >r >r deconstruct r> r> seq>> set-nth ; -M: tuple-array new-sequence tuple-array-example >tuple ; +M: tuple-array new-sequence + class>> new ; : >tuple-array ( seq -- tuple-array/seq ) dup empty? [ @@ -39,4 +30,6 @@ M: tuple-array new-sequence tuple-array-example >tuple ; M: tuple-array like drop dup tuple-array? [ >tuple-array ] unless ; +M: tuple-array length seq>> length ; + INSTANCE: tuple-array sequence From 1026587d631263942a4a5e6491fb944ffa2f46c6 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 18:07:04 -0500 Subject: [PATCH 08/19] add math.geometry.rect --- extra/math/geometry/rect/rect.factor | 42 ++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 extra/math/geometry/rect/rect.factor diff --git a/extra/math/geometry/rect/rect.factor b/extra/math/geometry/rect/rect.factor new file mode 100644 index 0000000000..51f42c22ca --- /dev/null +++ b/extra/math/geometry/rect/rect.factor @@ -0,0 +1,42 @@ + +USING: kernel arrays math.vectors ; + +IN: math.geometry.rect + +TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; + +: ( -- rect ) rect new ; + +C: 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 ; + +: ( loc ext -- rect ) over [v-] ; + +: offset-rect ( rect loc -- newrect ) + over rect-loc v+ swap rect-dim ; + +: (rect-intersect) ( rect rect -- array array ) + 2rect-extent vmin >r vmax r> ; + +: rect-intersect ( rect1 rect2 -- newrect ) + (rect-intersect) ; + +: 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) ; + From 6235d0b16f7e1c0394461225cd235e557764dd48 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 18:13:41 -0500 Subject: [PATCH 09/19] gadgets: remove rect (moved to math.geometry.rect) --- extra/ui/gadgets/gadgets.factor | 43 +++------------------------------ 1 file changed, 4 insertions(+), 39 deletions(-) diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 5bfb5a1b05..a274dc2392 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -1,51 +1,16 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays hashtables kernel models math namespaces -sequences quotations math.vectors combinators sorting vectors -dlists dequeues models threads concurrency.flags math.order ; + sequences quotations math.vectors combinators sorting vectors + dlists dequeues models threads concurrency.flags + math.order math.geometry.rect ; + IN: ui.gadgets SYMBOL: ui-notify-flag : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ; -TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; - -: ( -- rect ) rect new ; - -C: 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 ; - -: ( loc ext -- rect ) over [v-] ; - -: offset-rect ( rect loc -- newrect ) - over rect-loc v+ swap rect-dim ; - -: (rect-intersect) ( rect rect -- array array ) - 2rect-extent vmin >r vmax r> ; - -: rect-intersect ( rect1 rect2 -- newrect ) - (rect-intersect) ; - -: 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) ; - TUPLE: gadget < rect pref-dim parent children orientation focus visible? root? clipped? layout-state graft-state graft-node From e0602a621d9e2f72d1d8e3847eaf54d263f3b2d1 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 18:14:05 -0500 Subject: [PATCH 10/19] add math.geometry.rect-docs --- extra/math/geometry/rect/rect-docs.factor | 54 +++++++++++++++++++++++ 1 file changed, 54 insertions(+) create mode 100644 extra/math/geometry/rect/rect-docs.factor diff --git a/extra/math/geometry/rect/rect-docs.factor b/extra/math/geometry/rect/rect-docs.factor new file mode 100644 index 0000000000..3e21dfe307 --- /dev/null +++ b/extra/math/geometry/rect/rect-docs.factor @@ -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 } " and " { $link } "." +} ; + +HELP: ( 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." } ; + +{ } 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: ( 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: +{ $values { "rect" "a new " { $link rect } } } +{ $description "Creates a rectangle located at the origin with zero dimensions." } ; + From 6a358bd391231601e6854761afbd7530e6777d84 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 18:14:30 -0500 Subject: [PATCH 11/19] gadgets-docs: remove rect help --- extra/ui/gadgets/gadgets-docs.factor | 52 +--------------------------- 1 file changed, 1 insertion(+), 51 deletions(-) diff --git a/extra/ui/gadgets/gadgets-docs.factor b/extra/ui/gadgets/gadgets-docs.factor index 8093aa5dc5..b9d12847be 100755 --- a/extra/ui/gadgets/gadgets-docs.factor +++ b/extra/ui/gadgets/gadgets-docs.factor @@ -1,53 +1,7 @@ USING: help.markup help.syntax opengl kernel strings -classes.tuple classes quotations models ; + classes.tuple classes quotations models math.geometry.rect ; 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 } " and " { $link } "." -} ; - -HELP: ( 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." } ; - -{ } 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: ( 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 { $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." } ; @@ -57,10 +11,6 @@ HELP: nth-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." } ; -HELP: -{ $values { "rect" "a new " { $link rect } } } -{ $description "Creates a rectangle located at the origin with zero dimensions." } ; - HELP: { $values { "gadget" "a new " { $link gadget } } } { $description "Creates a new gadget." } ; From 75991cf7ce74bc391a8feff753dc4785e2703f80 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 18:34:43 -0500 Subject: [PATCH 12/19] Edit USING: for 'math.geometry.rect' --- extra/ui/gadgets/books/books.factor | 2 +- extra/ui/gadgets/borders/borders.factor | 2 +- extra/ui/gadgets/buttons/buttons.factor | 2 +- extra/ui/gadgets/editors/editors.factor | 3 ++- extra/ui/gadgets/frames/frames.factor | 3 ++- extra/ui/gadgets/grid-lines/grid-lines.factor | 2 +- extra/ui/gadgets/grids/grids.factor | 3 ++- extra/ui/gadgets/incremental/incremental.factor | 2 +- extra/ui/gadgets/lists/lists.factor | 2 +- extra/ui/gadgets/menus/menus.factor | 3 ++- extra/ui/gadgets/packs/packs.factor | 2 +- extra/ui/gadgets/panes/panes.factor | 2 +- extra/ui/gadgets/paragraphs/paragraphs.factor | 2 +- extra/ui/gadgets/scrollers/scrollers-docs.factor | 2 +- extra/ui/gadgets/scrollers/scrollers.factor | 2 +- extra/ui/gadgets/sliders/sliders.factor | 2 +- extra/ui/gadgets/tracks/tracks.factor | 2 +- extra/ui/gadgets/viewports/viewports.factor | 2 +- extra/ui/gadgets/worlds/worlds.factor | 2 +- extra/ui/render/render-docs.factor | 2 +- extra/ui/render/render.factor | 3 ++- extra/ui/ui-docs.factor | 2 +- extra/ui/x11/x11.factor | 2 +- 23 files changed, 28 insertions(+), 23 deletions(-) diff --git a/extra/ui/gadgets/books/books.factor b/extra/ui/gadgets/books/books.factor index 219a970943..93a8d271af 100755 --- a/extra/ui/gadgets/books/books.factor +++ b/extra/ui/gadgets/books/books.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! 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 TUPLE: book < gadget ; diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index 55d1993b1d..2c232392ce 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays ui.gadgets kernel math -namespaces vectors sequences math.vectors ; +namespaces vectors sequences math.vectors math.geometry.rect ; IN: ui.gadgets.borders TUPLE: border < gadget diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index 96a89e8aa6..a855a6d93e 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -6,7 +6,7 @@ classes.tuple opengl math.vectors ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures -ui.render ; +ui.render math.geometry.rect ; IN: ui.gadgets.buttons TUPLE: button < border pressed? selected? quot ; diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 1732d404ca..8b0244900a 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -5,7 +5,8 @@ namespaces opengl opengl.gl sequences strings io.styles math.vectors sorting colors combinators assocs math.order ui.clipboards ui.commands ui.gadgets ui.gadgets.borders 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 TUPLE: editor < gadget diff --git a/extra/ui/gadgets/frames/frames.factor b/extra/ui/gadgets/frames/frames.factor index 096d916a9b..717323c69a 100644 --- a/extra/ui/gadgets/frames/frames.factor +++ b/extra/ui/gadgets/frames/frames.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. 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 ! A frame arranges gadgets in a 3x3 grid, where the center diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor index 533116824b..d0cedc985b 100755 --- a/extra/ui/gadgets/grid-lines/grid-lines.factor +++ b/extra/ui/gadgets/grid-lines/grid-lines.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. 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 TUPLE: grid-lines color ; diff --git a/extra/ui/gadgets/grids/grids.factor b/extra/ui/gadgets/grids/grids.factor index 70aee4d1e3..b539934771 100644 --- a/extra/ui/gadgets/grids/grids.factor +++ b/extra/ui/gadgets/grids/grids.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. 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 TUPLE: grid < gadget diff --git a/extra/ui/gadgets/incremental/incremental.factor b/extra/ui/gadgets/incremental/incremental.factor index 418dd3b7c6..c74f6676ad 100755 --- a/extra/ui/gadgets/incremental/incremental.factor +++ b/extra/ui/gadgets/incremental/incremental.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io kernel math namespaces math.vectors ui.gadgets -ui.gadgets.packs accessors ; +ui.gadgets.packs accessors math.geometry.rect ; IN: ui.gadgets.incremental ! Incremental layout allows adding lines to panes to be O(1). diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor index 2b50453cf4..776814853f 100755 --- a/extra/ui/gadgets/lists/lists.factor +++ b/extra/ui/gadgets/lists/lists.factor @@ -4,7 +4,7 @@ USING: accessors ui.commands ui.gestures ui.render ui.gadgets ui.gadgets.labels ui.gadgets.scrollers kernel sequences models opengl math math.order namespaces ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs -math.vectors classes.tuple ; +math.vectors classes.tuple math.geometry.rect ; IN: ui.gadgets.lists TUPLE: list < pack index presenter color hook ; diff --git a/extra/ui/gadgets/menus/menus.factor b/extra/ui/gadgets/menus/menus.factor index 66dbb05d66..3e1145a8b6 100644 --- a/extra/ui/gadgets/menus/menus.factor +++ b/extra/ui/gadgets/menus/menus.factor @@ -3,7 +3,8 @@ USING: arrays ui.commands ui.gadgets ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic hashtables kernel math 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 : menu-loc ( world menu -- loc ) diff --git a/extra/ui/gadgets/packs/packs.factor b/extra/ui/gadgets/packs/packs.factor index 00f27af270..7ae222c279 100755 --- a/extra/ui/gadgets/packs/packs.factor +++ b/extra/ui/gadgets/packs/packs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. 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 TUPLE: pack < gadget diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 87eec35871..973c8c5725 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -9,7 +9,7 @@ quotations math opengl combinators math.vectors sorting splitting io.streams.nested assocs ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines classes.tuple models continuations -destructors accessors ; +destructors accessors math.geometry.rect ; IN: ui.gadgets.panes TUPLE: pane < pack diff --git a/extra/ui/gadgets/paragraphs/paragraphs.factor b/extra/ui/gadgets/paragraphs/paragraphs.factor index 12382be9cd..1946ff6db6 100644 --- a/extra/ui/gadgets/paragraphs/paragraphs.factor +++ b/extra/ui/gadgets/paragraphs/paragraphs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. 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 ! A word break gadget diff --git a/extra/ui/gadgets/scrollers/scrollers-docs.factor b/extra/ui/gadgets/scrollers/scrollers-docs.factor index ee82339f33..3554c735a7 100755 --- a/extra/ui/gadgets/scrollers/scrollers-docs.factor +++ b/extra/ui/gadgets/scrollers/scrollers-docs.factor @@ -1,5 +1,5 @@ USING: ui.gadgets help.markup help.syntax ui.gadgets.viewports -ui.gadgets.sliders ; +ui.gadgets.sliders math.geometry.rect ; IN: ui.gadgets.scrollers HELP: scroller diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor index 8cac3f4400..1fe3c606bb 100755 --- a/extra/ui/gadgets/scrollers/scrollers.factor +++ b/extra/ui/gadgets/scrollers/scrollers.factor @@ -4,7 +4,7 @@ USING: accessors arrays ui.gadgets ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math namespaces sequences models models.range models.compose -combinators math.vectors classes.tuple ; +combinators math.vectors classes.tuple math.geometry.rect ; IN: ui.gadgets.scrollers TUPLE: scroller < frame viewport x y follows ; diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor index da18dea142..b5d8862359 100755 --- a/extra/ui/gadgets/sliders/sliders.factor +++ b/extra/ui/gadgets/sliders/sliders.factor @@ -4,7 +4,7 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.grids math.order ui.gadgets.theme ui.render kernel math namespaces sequences vectors models models.range math.vectors math.functions -quotations colors ; +quotations colors math.geometry.rect ; IN: ui.gadgets.sliders TUPLE: elevator < gadget direction ; diff --git a/extra/ui/gadgets/tracks/tracks.factor b/extra/ui/gadgets/tracks/tracks.factor index f9276fd1a1..5de9b9d366 100644 --- a/extra/ui/gadgets/tracks/tracks.factor +++ b/extra/ui/gadgets/tracks/tracks.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. 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 TUPLE: track < pack sizes ; diff --git a/extra/ui/gadgets/viewports/viewports.factor b/extra/ui/gadgets/viewports/viewports.factor index 2e7e130404..100d6c8a39 100755 --- a/extra/ui/gadgets/viewports/viewports.factor +++ b/extra/ui/gadgets/viewports/viewports.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: ui.gadgets.viewports 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 diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor index 7064045cc4..dc4debd900 100755 --- a/extra/ui/gadgets/worlds/worlds.factor +++ b/extra/ui/gadgets/worlds/worlds.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs continuations kernel math models namespaces opengl sequences io combinators math.vectors ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks -debugger ; +debugger math.geometry.rect ; IN: ui.gadgets.worlds TUPLE: world < track diff --git a/extra/ui/render/render-docs.factor b/extra/ui/render/render-docs.factor index d48d7c99d9..0133b7bb1c 100755 --- a/extra/ui/render/render-docs.factor +++ b/extra/ui/render/render-docs.factor @@ -1,5 +1,5 @@ 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 HELP: gadget diff --git a/extra/ui/render/render.factor b/extra/ui/render/render.factor index 8f40bec1c3..6e9a4778a7 100644 --- a/extra/ui/render/render.factor +++ b/extra/ui/render/render.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays hashtables io kernel math namespaces opengl 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 SYMBOL: clip diff --git a/extra/ui/ui-docs.factor b/extra/ui/ui-docs.factor index 1a541090c5..72cb2c557e 100755 --- a/extra/ui/ui-docs.factor +++ b/extra/ui/ui-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax strings quotations debugger 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 HELP: windows diff --git a/extra/ui/x11/x11.factor b/extra/ui/x11/x11.factor index 35f22ec64f..b75daf89fa 100755 --- a/extra/ui/x11/x11.factor +++ b/extra/ui/x11/x11.factor @@ -6,7 +6,7 @@ assocs kernel math namespaces opengl sequences strings x11.xlib x11.events x11.xim x11.glx x11.clipboard x11.constants x11.windows io.encodings.string io.encodings.ascii 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 IN: ui.x11 From 24a063ea76ba94acb3da4cbaad61aaf4c0a606c9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 19:02:43 -0500 Subject: [PATCH 13/19] math.physics.pos and math.physics.vel --- extra/math/physics/pos/pos.factor | 5 +++++ extra/math/physics/vel/vel.factor | 7 +++++++ 2 files changed, 12 insertions(+) create mode 100644 extra/math/physics/pos/pos.factor create mode 100644 extra/math/physics/vel/vel.factor diff --git a/extra/math/physics/pos/pos.factor b/extra/math/physics/pos/pos.factor new file mode 100644 index 0000000000..1582c42108 --- /dev/null +++ b/extra/math/physics/pos/pos.factor @@ -0,0 +1,5 @@ + +IN: math.physics.pos + +TUPLE: pos pos ; + diff --git a/extra/math/physics/vel/vel.factor b/extra/math/physics/vel/vel.factor new file mode 100644 index 0000000000..5fc815e9b8 --- /dev/null +++ b/extra/math/physics/vel/vel.factor @@ -0,0 +1,7 @@ + +USING: math.physics.pos ; + +IN: math.physics.vel + +TUPLE: vel < pos vel ; + From b7b17ed879f63f57efb983f47ca613be24c837f5 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 19:03:15 -0500 Subject: [PATCH 14/19] boids: Use math.physics --- extra/boids/boids.factor | 25 ++++++++++++++----------- extra/boids/ui/ui.factor | 7 ++++--- 2 files changed, 18 insertions(+), 14 deletions(-) diff --git a/extra/boids/boids.factor b/extra/boids/boids.factor index e6c97b90dd..cff33c9d19 100644 --- a/extra/boids/boids.factor +++ b/extra/boids/boids.factor @@ -6,14 +6,17 @@ USING: combinators.short-circuit kernel namespaces math.order math.vectors math.trig + math.physics.pos + math.physics.vel combinators arrays sequences random vars - combinators.lib ; + combinators.lib + accessors ; IN: boids ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: boid pos vel ; +TUPLE: boid < vel ; C: 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 ) -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 ; -: 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 empty? [ 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -143,7 +146,7 @@ over boid-vel -rot relative-position angle-between ; dup separation-neighborhood dup empty? [ 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 ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -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 ) - [ 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 ; diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index e3c54e0744..ab1f8e5f80 100755 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -19,7 +19,8 @@ USING: combinators.short-circuit kernel namespaces ui.gadgets.packs ui.gadgets.grids ui.gestures - assocs.lib vars rewrite-closures boids ; + assocs.lib vars rewrite-closures boids accessors + math.geometry.rect ; IN: boids.ui @@ -27,9 +28,9 @@ IN: boids.ui ! 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 ; From ba6d70b7f728adbf2c55cc6cd9b3853ef45e1753 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 19:28:48 -0500 Subject: [PATCH 15/19] springies: use math.physics --- extra/springies/springies.factor | 69 ++++++++++++++++++-------------- extra/springies/ui/ui.factor | 6 +-- 2 files changed, 42 insertions(+), 33 deletions(-) diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index 1856115863..2640423eb4 100755 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -1,6 +1,6 @@ USING: kernel combinators sequences arrays math math.vectors - generalizations vars ; + generalizations vars accessors math.physics.vel ; IN: springies @@ -28,23 +28,27 @@ VAR: gravity ! node ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -TUPLE: node mass elas pos vel force ; +! TUPLE: node mass elas pos vel force ; + +TUPLE: node < vel mass elas force ; C: 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 ; -: pos-y ( node -- y ) node-pos second ; -: vel-x ( node -- y ) node-vel first ; -: vel-y ( node -- y ) node-vel second ; +: set-node-vel ( vel node -- ) swap >>vel drop ; -: >>pos-x ( node x -- node ) over node-pos set-first ; -: >>pos-y ( node y -- node ) over node-pos set-second ; -: >>vel-x ( node x -- node ) over node-vel set-first ; -: >>vel-y ( node y -- node ) over node-vel set-second ; +: pos-x ( node -- x ) pos>> first ; +: 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 ; @@ -61,7 +65,7 @@ TUPLE: spring rest-length k damp node-a node-b ; C: spring : 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 ; @@ -112,10 +116,10 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : 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 ) - [ 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-a ] [ unit-vec-b->a ] bi vector-projection ; @@ -126,10 +130,10 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : 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 ) - [ 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-b ] [ unit-vec-a->b ] bi vector-projection ; @@ -210,9 +214,9 @@ C: spring : calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ; : 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 -- ) dup new-pos >>pos @@ -231,16 +235,21 @@ C: spring ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : mass ( id x y x-vel y-vel mass elas -- ) - 7 nrot drop - 6 nrot 6 nrot 2array - 5 nrot 5 nrot 2array - 0 0 2array - nodes> swap suffix >nodes ; + node new + swap >>elas + swap >>mass + -rot 2array >>vel + -rot 2array >>pos + 0 0 2array >>force + nodes> swap suffix >nodes + drop ; : spng ( id id-a id-b k damp rest-length -- ) - 6 nrot drop - -rot - 5 nrot node-id - 5 nrot node-id - - springs> swap suffix >springs ; + spring new + swap >>rest-length + swap >>damp + swap >>k + swap node-id >>node-b + swap node-id >>node-a + springs> swap suffix >springs + drop ; \ No newline at end of file diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor index 8aabe6b70b..365632e974 100644 --- a/extra/springies/ui/ui.factor +++ b/extra/springies/ui/ui.factor @@ -1,16 +1,16 @@ USING: kernel namespaces threads sequences math math.vectors 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 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: 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 -- ) - [ 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 ; From e890b7a4bc53cb417d8782de8f39a821f735e9eb Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 20:31:15 -0500 Subject: [PATCH 16/19] More math.geometry.rect updates --- extra/ui/cocoa/cocoa.factor | 2 +- extra/ui/windows/windows.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index bf28740ecc..0085376eaa 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.classes cocoa.application sequences system 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 TUPLE: handle view window ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 231dd7f8a5..a210287439 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -8,7 +8,7 @@ sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations 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 SINGLETON: windows-ui-backend From 466a3fecd16166834e5a2bd254a14772c3a592fe Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 20:47:07 -0500 Subject: [PATCH 17/19] ui.cocoa.views: math.geometry.rect --- extra/ui/cocoa/views/views.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/cocoa/views/views.factor b/extra/ui/cocoa/views/views.factor index 68db5954d5..3bacad20b4 100755 --- a/extra/ui/cocoa/views/views.factor +++ b/extra/ui/cocoa/views/views.factor @@ -4,7 +4,7 @@ USING: accessors alien alien.c-types arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing cocoa.classes cocoa.views cocoa.application cocoa.pasteboard cocoa.types cocoa.windows sequences ui ui.gadgets ui.gadgets.worlds ui.gestures -core-foundation threads combinators ; +core-foundation threads combinators math.geometry.rect ; IN: ui.cocoa.views : send-mouse-moved ( view event -- ) From e08a04a03d532bd0948ecf1dfb6e805be488d79a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 20:58:09 -0500 Subject: [PATCH 18/19] automata.ui: math.geometry.rect --- extra/automata/ui/ui.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index 467db53366..cfec6597c2 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -15,7 +15,7 @@ USING: kernel namespaces math quotations arrays hashtables sequences threads ui.gadgets.grids ui.gadgets.theme namespaces.lib assocs.lib vars - rewrite-closures automata ; + rewrite-closures automata math.geometry.rect ; IN: automata.ui From b668936d9fa63bbf12deb37a0b1e17999c60a979 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 11 Jul 2008 21:06:31 -0500 Subject: [PATCH 19/19] more rect updates --- extra/color-picker/color-picker.factor | 2 +- extra/jamshred/jamshred.factor | 5 ++++- extra/maze/maze.factor | 2 +- extra/processing/processing.factor | 2 +- extra/springies/springies.factor | 2 ++ extra/tetris/tetris.factor | 3 ++- extra/ui/gadgets/frame-buffer/frame-buffer.factor | 2 +- 7 files changed, 12 insertions(+), 6 deletions(-) diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index 99968ca3c3..6fcf3c21cd 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -3,7 +3,7 @@ USING: kernel math math.functions math.parser models models.filter models.range models.compose sequences ui 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 ! Simple example demonstrating the use of models. diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index b7764894d1..d9a0f84b53 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,6 +1,9 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! 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 TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; diff --git a/extra/maze/maze.factor b/extra/maze/maze.factor index dbf983be62..389dabc0f6 100644 --- a/extra/maze/maze.factor +++ b/extra/maze/maze.factor @@ -1,7 +1,7 @@ ! From http://www.ffconsultancy.com/ocaml/maze/index.html USING: sequences namespaces math math.vectors opengl opengl.gl arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render -math.order ; +math.order math.geometry.rect ; IN: maze : line-width 8 ; diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index fb9f321f47..4c9dd787e5 100755 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -10,7 +10,7 @@ USING: kernel namespaces threads combinators sequences arrays combinators.cleave rewrite-closures fry accessors newfx processing.color - processing.gadget ; + processing.gadget math.geometry.rect ; IN: processing diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index 2640423eb4..fb69783975 100755 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -38,6 +38,8 @@ C: node ! : >>vel ( node vel -- node ) over set-node-vel ; +: node-vel ( node -- vel ) vel>> ; + : set-node-vel ( vel node -- ) swap >>vel drop ; : pos-x ( node -- x ) pos>> first ; diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor index c2f874598c..d01cec3790 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels 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 TUPLE: tetris-gadget tetris alarm ; diff --git a/extra/ui/gadgets/frame-buffer/frame-buffer.factor b/extra/ui/gadgets/frame-buffer/frame-buffer.factor index a288f74f64..7d77db24cc 100644 --- a/extra/ui/gadgets/frame-buffer/frame-buffer.factor +++ b/extra/ui/gadgets/frame-buffer/frame-buffer.factor @@ -1,7 +1,7 @@ USING: kernel alien.c-types combinators sequences splitting grouping opengl.gl ui.gadgets ui.render - math math.vectors accessors ; + math math.vectors accessors math.geometry.rect ; IN: ui.gadgets.frame-buffer