From 7e6479cd365a0a8084594d3ff3261d9d15023d32 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 14 Feb 2010 15:59:18 -0600 Subject: [PATCH 01/15] collect-benchmarks needs to convert from nano not micro --- extra/project-euler/ave-time/ave-time.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/project-euler/ave-time/ave-time.factor b/extra/project-euler/ave-time/ave-time.factor index ec190fed18..9927486eb7 100644 --- a/extra/project-euler/ave-time/ave-time.factor +++ b/extra/project-euler/ave-time/ave-time.factor @@ -1,11 +1,11 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.smart formatting fry io kernel macros math -math.functions math.statistics memory sequences tools.time ; +USING: combinators.smart formatting fry io kernel macros math math.functions +math.statistics memory sequences tools.time ; IN: project-euler.ave-time MACRO: collect-benchmarks ( quot n -- seq ) - swap '[ _ [ [ [ _ nullary ] preserving ] gc benchmark 1000 / ] replicate ] ; + swap '[ _ [ [ [ _ nullary ] preserving ] gc benchmark 6 10^ / ] replicate ] ; : ave-time ( quot n -- ) [ From e772aae5103cad688fde0e71c425163a03032015 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 14 Feb 2010 16:00:08 -0600 Subject: [PATCH 02/15] Typo in command-line docs --- basis/command-line/command-line-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/command-line/command-line-docs.factor b/basis/command-line/command-line-docs.factor index 11ee46c227..9a69614766 100644 --- a/basis/command-line/command-line-docs.factor +++ b/basis/command-line/command-line-docs.factor @@ -91,7 +91,7 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage" } ; ARTICLE: "factor-boot-rc" "Bootstrap initialization file" -"The botstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts." +"The bootstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts." $nl "A word to run this file from an existing Factor session:" { $subsections run-bootstrap-init } From e19461d4106950e9300937d30a6d1f2bb9a5e5c5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Feb 2010 17:15:26 +1300 Subject: [PATCH 03/15] io.files.info: load io.files.info.unix if we're on Unix. Fixes long-standing no-method error on file-info --- basis/io/files/info/info.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index 500fd62cd3..a314361e9d 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -26,7 +26,7 @@ available-space free-space used-space total-space ; HOOK: file-system-info os ( path -- file-system-info ) { - { [ os unix? ] [ "io.files.info" ] } + { [ os unix? ] [ "io.files.info.unix" ] } { [ os windows? ] [ "io.files.info.windows" ] } } cond require From 62f5a2af1cf0aeb1a764c1e055c97124f00ee04c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Feb 2010 17:37:07 +1300 Subject: [PATCH 04/15] tools.deploy.shaker: don't strip out io.files hook, since then we lose resource-path and such --- basis/tools/deploy/deploy-tests.factor | 6 ++++++ basis/tools/deploy/shaker/shaker.factor | 1 - basis/tools/deploy/test/18/18.factor | 8 ++++++++ basis/tools/deploy/test/18/authors.txt | 1 + basis/tools/deploy/test/18/deploy.factor | 14 ++++++++++++++ 5 files changed, 29 insertions(+), 1 deletion(-) create mode 100644 basis/tools/deploy/test/18/18.factor create mode 100644 basis/tools/deploy/test/18/authors.txt create mode 100644 basis/tools/deploy/test/18/deploy.factor diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 1412e65f95..987b4aa8a1 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -117,3 +117,9 @@ os macosx? [ [ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test [ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test + +[ t ] [ + "tools.deploy.test.18" shake-and-bake + deploy-test-command ascii [ readln ] with-process-reader + "test.image" temp-file = +] unit-test diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 5897712a02..e5dddc5fe6 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -43,7 +43,6 @@ IN: tools.deploy.shaker "io.thread" startup-hooks get delete-at ] unless strip-io? [ - "io.files" startup-hooks get delete-at "io.backend" startup-hooks get delete-at "io.thread" startup-hooks get delete-at ] when diff --git a/basis/tools/deploy/test/18/18.factor b/basis/tools/deploy/test/18/18.factor new file mode 100644 index 0000000000..0676376701 --- /dev/null +++ b/basis/tools/deploy/test/18/18.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2010 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors io.streams.c math.parser system ; +IN: tools.deploy.test.18 + +: main ( -- ) image show ; + +MAIN: main diff --git a/basis/tools/deploy/test/18/authors.txt b/basis/tools/deploy/test/18/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/deploy/test/18/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/deploy/test/18/deploy.factor b/basis/tools/deploy/test/18/deploy.factor new file mode 100644 index 0000000000..66069d6430 --- /dev/null +++ b/basis/tools/deploy/test/18/deploy.factor @@ -0,0 +1,14 @@ +USING: tools.deploy.config ; +H{ + { deploy-name "tools.deploy.test.18" } + { deploy-ui? f } + { deploy-c-types? f } + { deploy-unicode? f } + { "stop-after-last-window?" t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-word-props? f } + { deploy-math? f } + { deploy-threads? f } + { deploy-word-defs? f } +} From 4266023639c0912afe93511953e32f4e53053ba1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Feb 2010 17:54:19 +1300 Subject: [PATCH 05/15] tools.deploy.shaker: strip out vm, image, current-directory to avoid leaking information from build environment --- basis/tools/deploy/shaker/shaker.factor | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e5dddc5fe6..1060853343 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2007, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays accessors io.backend io.streams.c init fry -namespaces math make assocs kernel parser parser.notes lexer -strings.parser vocabs sequences sequences.deep sequences.private -words memory kernel.private continuations io vocabs.loader -system strings sets vectors quotations byte-arrays sorting -compiler.units definitions generic generic.standard +USING: arrays accessors io.backend io.pathnames io.streams.c +init fry namespaces math make assocs kernel parser parser.notes +lexer strings.parser vocabs sequences sequences.deep +sequences.private words memory kernel.private continuations io +vocabs.loader system strings sets vectors quotations byte-arrays +sorting compiler.units definitions generic generic.standard generic.single tools.deploy.config combinators classes classes.builtin slots.private grouping command-line ; QUALIFIED: bootstrap.stage2 @@ -48,7 +48,6 @@ IN: tools.deploy.shaker ] when strip-dictionary? [ { - ! "compiler.units" "vocabs" "vocabs.cache" "source-files.errors" @@ -293,6 +292,9 @@ IN: tools.deploy.shaker input-stream output-stream error-stream + vm + image + current-directory } % "io-thread" "io.thread" lookup , From 3e5e3a6d3fb6800dc178afdf4eff4964951d6484 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Feb 2010 18:34:45 +1300 Subject: [PATCH 06/15] classes: call reset-generic on predicate word to avoid redefinition problems (reported by littledan) --- core/classes/classes-tests.factor | 6 ++++++ core/classes/classes.factor | 3 ++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 10a5f674bd..2b02d7c5a1 100644 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -119,3 +119,9 @@ TUPLE: forgotten-predicate-test ; [ ] [ [ \ forgotten-predicate-test forget ] with-compilation-unit ] unit-test [ f ] [ \ forgotten-predicate-test? predicate? ] unit-test + +GENERIC: generic-predicate? ( a -- b ) + +[ ] [ "IN: classes.tests TUPLE: generic-predicate ;" eval( -- ) ] unit-test + +[ f ] [ \ generic-predicate? generic? ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 6d68ad7fb4..a730636ca9 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -60,7 +60,8 @@ PRIVATE> : classes ( -- seq ) implementors-map get keys ; : create-predicate-word ( word -- predicate ) - [ name>> "?" append ] [ vocabulary>> ] bi create ; + [ name>> "?" append ] [ vocabulary>> ] bi + create dup reset-generic ; : predicate-word ( word -- predicate ) "predicate" word-prop first ; From 97428db9212ecf7866459fa266b3148fc933066e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Feb 2010 19:01:19 +1300 Subject: [PATCH 07/15] mason.source: save git-id in source packages, just like binary packages --- extra/mason/source/source.factor | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/extra/mason/source/source.factor b/extra/mason/source/source.factor index 3a3d6a66b7..72c63660e3 100644 --- a/extra/mason/source/source.factor +++ b/extra/mason/source/source.factor @@ -8,11 +8,17 @@ IN: mason.source : clone-factor ( -- ) { "git" "clone" } home "factor" append-path suffix try-process ; +: save-git-id ( -- ) + git-id "git-id" to-file ; + +: delete-git-tree ( -- ) + ".git" delete-tree ; + +: download-images ( -- ) + images [ download-image ] each ; + : prepare-source ( -- ) - "factor" [ - ".git" delete-tree - images [ download-image ] each - ] with-directory ; + "factor" [ save-git-id delete-git-tree download-images ] with-directory ; : package-name ( version -- string ) "factor-src-" ".zip" surround ; From cd1986a906e06d333859232d9e1fc890e38a2906 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 15 Feb 2010 23:46:55 +1300 Subject: [PATCH 08/15] classes: fix regression from recent bug fix --- core/classes/classes.factor | 8 ++++---- core/classes/tuple/tuple-tests.factor | 6 ++++++ 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index a730636ca9..28f0b192ee 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -59,15 +59,15 @@ PRIVATE> : classes ( -- seq ) implementors-map get keys ; +PREDICATE: predicate < word "predicating" word-prop >boolean ; + : create-predicate-word ( word -- predicate ) - [ name>> "?" append ] [ vocabulary>> ] bi - create dup reset-generic ; + [ name>> "?" append ] [ vocabulary>> ] bi create + dup predicate? [ dup reset-generic ] unless ; : predicate-word ( word -- predicate ) "predicate" word-prop first ; -PREDICATE: predicate < word "predicating" word-prop >boolean ; - M: predicate flushable? drop t ; M: predicate forget* diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index f452d8fb28..36d402c61d 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -764,3 +764,9 @@ DEFER: factor-crashes-anymore ] unit-test [ 31337 ] [ factor-crashes-anymore ] unit-test + +TUPLE: tuple-predicate-redefine-test ; + +[ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test + +[ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test From 64a37d2db6827239a355088356a6e5958953a0db Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Feb 2010 01:03:09 +1300 Subject: [PATCH 09/15] compiler.tree.propagation.transforms: tweak 2^ transform to fix performance regression in benchmark.beust2; introduced by 47d6507548a7bcbcf27af29d3fa9df00ed4f6130 --- .../compiler/tree/propagation/transforms/transforms.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index da3bd58f74..0077d0f123 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -103,13 +103,10 @@ IN: compiler.tree.propagation.transforms ! Speeds up 2^ : 2^? ( #call -- ? ) - in-d>> first2 [ value-info ] bi@ - [ { [ literal>> 1 = ] [ class>> fixnum class<= ] } 1&& ] - [ class>> fixnum class<= ] - bi* and ; + in-d>> first value-info literal>> 1 eq? ; \ shift [ - 2^? [ + 2^? [ cell-bits tag-bits get - 1 - '[ >fixnum dup 0 < [ 2drop 0 ] [ From 4893ebf183da449a4bac116e4dd9333d54aecc88 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Feb 2010 04:04:09 +1300 Subject: [PATCH 10/15] Small cleanups --- basis/io/backend/unix/unix.factor | 8 ++------ basis/io/directories/unix/linux/linux.factor | 2 +- basis/io/styles/styles.factor | 6 ------ basis/math/bitwise/bitwise.factor | 2 +- basis/prettyprint/stylesheet/stylesheet.factor | 7 +++++++ 5 files changed, 11 insertions(+), 14 deletions(-) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 1797edccf6..39f0a5fec3 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -22,10 +22,6 @@ TUPLE: fd < disposable fd ; ] with-destructors ; : ( n -- fd ) - #! We drop the error code rather than calling io-error, - #! since on OS X 10.3, this operation fails from init-io - #! when running the Factor.app (presumably because fd 0 and - #! 1 are closed). fd new-disposable swap >>fd ; M: fd dispose @@ -197,5 +193,5 @@ TUPLE: mx-port < port mx ; [ drop 0 ] [ (io-error) ] if ] when ; -: ?flag ( n mask symbol -- n ) - pick rot bitand 0 > [ , ] [ drop ] if ; +:: ?flag ( n mask symbol -- n ) + n mask bitand 0 > [ symbol , ] when n ; diff --git a/basis/io/directories/unix/linux/linux.factor b/basis/io/directories/unix/linux/linux.factor index 932cbe230b..3d69c5f890 100644 --- a/basis/io/directories/unix/linux/linux.factor +++ b/basis/io/directories/unix/linux/linux.factor @@ -4,7 +4,7 @@ USING: alien.c-types io.directories.unix kernel system unix classes.struct unix.ffi ; IN: io.directories.unix.linux -M: unix find-next-file ( DIR* -- dirent ) +M: linux find-next-file ( DIR* -- dirent ) dirent f [ [ readdir64_r ] unix-system-call 0 = [ (io-error) ] unless ] 2keep diff --git a/basis/io/styles/styles.factor b/basis/io/styles/styles.factor index ae493be849..d4e1d2c557 100644 --- a/basis/io/styles/styles.factor +++ b/basis/io/styles/styles.factor @@ -163,9 +163,3 @@ M: input summary : write-object ( str obj -- ) presented associate format ; : write-image ( image -- ) [ "" ] dip image associate format ; - -SYMBOL: stack-effect-style -H{ - { foreground COLOR: FactorDarkGreen } - { font-style plain } -} stack-effect-style set-global diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 204f295944..6b301fa97b 100644 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -99,7 +99,7 @@ M: bignum (bit-count) ] if ; : byte-array-bit-count ( byte-array -- n ) - 0 [ byte-bit-count + ] reduce ; + 0 [ byte-bit-count + ] reduce ; inline PRIVATE> diff --git a/basis/prettyprint/stylesheet/stylesheet.factor b/basis/prettyprint/stylesheet/stylesheet.factor index 42a701d60f..bd25438b74 100644 --- a/basis/prettyprint/stylesheet/stylesheet.factor +++ b/basis/prettyprint/stylesheet/stylesheet.factor @@ -42,5 +42,12 @@ PRIVATE> : vocab-style ( vocab -- style ) dim-color colored-presentation-style ; +SYMBOL: stack-effect-style + +H{ + { foreground COLOR: FactorDarkGreen } + { font-style plain } +} stack-effect-style set-global + : effect-style ( effect -- style ) presented associate stack-effect-style get assoc-union ; From c7454d8bba46b8b442e73514744e90f61a58e0f9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Feb 2010 13:56:11 +1300 Subject: [PATCH 11/15] tools.annotations: fix for nanoseconds --- basis/tools/annotations/annotations.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 5d4a9226ce..c9dfc4a562 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2009 Slava Pestov. +! Copyright (C) 2005, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel math sorting words parser io summary quotations sequences prettyprint continuations effects @@ -108,5 +108,5 @@ PRIVATE> : word-timing. ( -- ) word-timing get - >alist [ 1000000 /f ] assoc-map sort-values + >alist [ 1,000,000,000 /f ] assoc-map sort-values simple-table. ; From daab7f8fc016fb514354914e91d6677f4ea2a91d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Feb 2010 13:56:36 +1300 Subject: [PATCH 12/15] benchmark.raytracer-simd: make some changes to improve performance --- .../raytracer-simd/raytracer-simd.factor | 109 ++++++++---------- 1 file changed, 47 insertions(+), 62 deletions(-) diff --git a/extra/benchmark/raytracer-simd/raytracer-simd.factor b/extra/benchmark/raytracer-simd/raytracer-simd.factor index dcdc911cbf..e90708c62d 100644 --- a/extra/benchmark/raytracer-simd/raytracer-simd.factor +++ b/extra/benchmark/raytracer-simd/raytracer-simd.factor @@ -1,13 +1,14 @@ ! Factor port of the raytracer benchmark from -! http://www.ffconsultancy.com/free/ray_tracer/languages.html +! http://www.ffconsultancy.com/languages/ray_tracer/index.html USING: arrays accessors io io.files io.files.temp io.encodings.binary kernel math math.constants math.functions -math.vectors math.vectors.simd math.vectors.simd.cords math.parser -make sequences sequences.private words hints classes.struct ; -QUALIFIED-WITH: alien.c-types c +math.vectors math.vectors.simd math.vectors.simd.cords +math.parser make sequences words combinators ; IN: benchmark.raytracer-simd +<< SYNTAX: no-compile word t "no-compile" set-word-prop ; >> + ! parameters ! Normalized { -1 -3 2 }. @@ -25,7 +26,7 @@ CONSTANT: levels 3 CONSTANT: size 200 -: delta ( -- n ) epsilon sqrt ; inline +: delta ( -- n ) epsilon sqrt ; inline no-compile TUPLE: ray { orig double-4 read-only } { dir double-4 read-only } ; @@ -35,80 +36,69 @@ TUPLE: hit { normal double-4 read-only } { lambda float read-only } ; C: hit -GENERIC: intersect-scene ( hit ray scene -- hit ) - TUPLE: sphere { center double-4 read-only } { radius float read-only } ; C: sphere -: sphere-v ( sphere ray -- v ) - [ center>> ] [ orig>> ] bi* v- ; inline +: sphere-v ( sphere ray -- v ) [ center>> ] [ orig>> ] bi* v- ; inline no-compile -: sphere-b ( v ray -- b ) - dir>> v. ; inline +: sphere-b ( v ray -- b ) dir>> v. ; inline no-compile -: sphere-d ( sphere b v -- d ) - [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline +: sphere-d ( sphere b v -- d ) [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline no-compile -: -+ ( x y -- x-y x+y ) - [ - ] [ + ] 2bi ; inline +: -+ ( x y -- x-y x+y ) [ - ] [ + ] 2bi ; inline no-compile : sphere-t ( b d -- t ) -+ dup 0.0 < - [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline + [ 2drop 1/0. ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline no-compile : sphere-b&v ( sphere ray -- b v ) [ sphere-v ] [ nip ] 2bi - [ sphere-b ] [ drop ] 2bi ; inline + [ sphere-b ] [ drop ] 2bi ; inline no-compile : ray-sphere ( sphere ray -- t ) [ drop ] [ sphere-b&v ] 2bi [ drop ] [ sphere-d ] 3bi - dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline + dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline no-compile -: if-ray-sphere ( hit ray sphere quot -- hit ) - #! quot: hit ray sphere l -- hit +: if-ray-sphere ( hit ray sphere quot: ( hit ray sphere l -- hit ) -- hit ) [ [ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri [ drop ] [ < ] 2bi - ] dip [ 3drop ] if ; inline + ] dip [ 3drop ] if ; inline no-compile : sphere-n ( ray sphere l -- n ) [ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri* - swap [ v*n ] dip v- v+ ; inline - -M: sphere intersect-scene ( hit ray sphere -- hit ) - [ [ sphere-n normalize ] keep nip ] if-ray-sphere ; - -HINTS: M\ sphere intersect-scene { hit ray sphere } ; + swap [ v*n ] dip v- v+ ; inline no-compile TUPLE: group < sphere { objs array read-only } ; : ( objs bound -- group ) - [ center>> ] [ radius>> ] bi rot group boa ; inline + swap [ [ center>> ] [ radius>> ] bi ] dip group boa ; inline no-compile : make-group ( bound quot -- ) - swap [ { } make ] dip ; inline + swap [ { } make ] dip ; inline no-compile -M: group intersect-scene ( hit ray group -- hit ) - [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ; - -HINTS: M\ group intersect-scene { hit ray group } ; +: intersect-scene ( hit ray scene -- hit ) + { + { [ dup group? ] [ [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ] } + { [ dup sphere? ] [ [ [ sphere-n normalize ] keep nip ] if-ray-sphere ] } + } cond ; inline recursive no-compile CONSTANT: initial-hit T{ hit f double-4{ 0.0 0.0 0.0 0.0 } 1/0. } : initial-intersect ( ray scene -- hit ) - [ initial-hit ] 2dip intersect-scene ; inline + [ initial-hit ] 2dip intersect-scene ; inline no-compile : ray-o ( ray hit -- o ) [ [ orig>> ] [ normal>> delta v*n ] bi* ] [ [ dir>> ] [ lambda>> ] bi* v*n ] - 2bi v+ v+ ; inline + 2bi v+ v+ ; inline no-compile : sray-intersect ( ray scene hit -- ray ) - swap [ ray-o light vneg ] dip initial-intersect ; inline + swap [ ray-o light vneg ] dip initial-intersect ; inline no-compile -: ray-g ( hit -- g ) normal>> light v. ; inline +: ray-g ( hit -- g ) normal>> light v. ; inline no-compile : cast-ray ( ray scene -- g ) 2dup initial-intersect dup lambda>> 1/0. = [ @@ -116,66 +106,61 @@ CONSTANT: initial-hit T{ hit f double-4{ 0.0 0.0 0.0 0.0 } 1/0. } ] [ [ sray-intersect lambda>> 1/0. = ] keep swap [ ray-g neg ] [ drop 0.0 ] if - ] if ; inline + ] if ; inline no-compile : create-center ( c r d -- c2 ) - [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline + [ 3.0 12.0 sqrt / * ] dip n*v v+ ; inline no-compile DEFER: create ( level c r -- scene ) : create-step ( level c r d -- scene ) over [ create-center ] dip 2.0 / [ 1 - ] 2dip create ; -: create-offsets ( quot -- ) +CONSTANT: create-offsets { double-4{ -1.0 1.0 -1.0 0.0 } double-4{ 1.0 1.0 -1.0 0.0 } double-4{ -1.0 1.0 1.0 0.0 } double-4{ 1.0 1.0 1.0 0.0 } - } swap each ; inline + } : create-bound ( c r -- sphere ) 3.0 * ; : create-group ( level c r -- scene ) 2dup create-bound [ 2dup , - [ [ 3dup ] dip create-step , ] create-offsets 3drop + create-offsets [ create-step , ] with with with each ] make-group ; : create ( level c r -- scene ) pick 1 = [ nip ] [ create-group ] if ; : ss-point ( dx dy -- point ) - [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ; + [ oversampling /f ] bi@ 0.0 0.0 double-4-boa ; inline no-compile -: ss-grid ( -- ss-grid ) - oversampling iota [ oversampling iota [ ss-point ] with map ] map ; +: ray-pixel ( scene point -- ray-grid ) + [ 0.0 ] 2dip + oversampling iota [ + oversampling iota [ + ss-point v+ normalize + double-4{ 0.0 0.0 -4.0 0.0 } swap + swap cast-ray + + ] with with with each + ] with with each ; inline no-compile -: ray-grid ( point ss-grid -- ray-grid ) - [ - [ v+ normalize double-4{ 0.0 0.0 -4.0 0.0 } swap ] with map - ] with map ; - -: ray-pixel ( scene point -- n ) - ss-grid ray-grid [ 0.0 ] 2dip - [ [ swap cast-ray + ] with each ] with each ; - -: pixel-grid ( -- grid ) - size iota reverse [ +: ray-trace ( scene -- grid ) + size iota [ size iota [ [ size 0.5 * - ] bi@ swap size - 0.0 double-4-boa - ] with map - ] map ; + 0.0 double-4-boa ray-pixel + ] with with map + ] with map ; : pgm-header ( w h -- ) "P5\n" % swap # " " % # "\n255\n" % ; : pgm-pixel ( n -- ) 255 * 0.5 + >fixnum , ; -: ray-trace ( scene -- pixels ) - pixel-grid [ [ ray-pixel ] with map ] with map ; - : run ( -- string ) levels double-4{ 0.0 -1.0 0.0 0.0 } 1.0 create ray-trace [ size size pgm-header From b963d56aacf9f85b26f0c19cb804197da05ae093 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Feb 2010 14:44:13 +1300 Subject: [PATCH 13/15] compiler.tree.escape-analysis: fix bug that comes up when inheritance is used --- .../escape-analysis-tests.factor | 15 +++++++++++++ .../tree/escape-analysis/simple/simple.factor | 22 ++++++++++++------- 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index 6c50347c3a..ca2f5ed197 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -329,3 +329,18 @@ TUPLE: empty-tuple ; [ { vector } declare length>> ] count-unboxed-allocations ] unit-test + +! Bug found while tweaking benchmark.raytracer-simd + +TUPLE: point-2d { x read-only } { y read-only } ; +TUPLE: point-3d < point-2d { z read-only } ; + +[ 0 ] [ + [ { point-2d } declare dup point-3d? [ z>> ] [ x>> ] if ] + count-unboxed-allocations +] unit-test + +[ 0 ] [ + [ point-2d boa dup point-3d? [ z>> ] [ x>> ] if ] + count-unboxed-allocations +] unit-test diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index 5be206f2f8..9634bdf259 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -61,22 +61,28 @@ M: #push escape-analysis* : record-tuple-allocation ( #call -- ) dup immutable-tuple-boa? - [ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation ] + [ [ in-d>> but-last { } like ] [ out-d>> first ] bi record-allocation ] [ record-unknown-allocation ] if ; : slot-offset ( #call -- n/f ) - dup in-d>> - [ second node-value-info literal>> ] - [ first node-value-info class>> ] 2bi - 2dup [ fixnum? ] [ tuple class<= ] bi* and [ - over 2 >= [ drop 2 - ] [ 2drop f ] if + dup in-d>> second node-value-info literal>> dup [ 2 - ] when ; + +: valid-slot-offset? ( slot# in -- ? ) + over [ + allocation dup [ + dup array? [ bounds-check? ] [ 2drop f ] if + ] [ 2drop t ] if ] [ 2drop f ] if ; +: unknown-slot-call ( out slot# in -- ) + [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ; + : record-slot-call ( #call -- ) - [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri over + [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri + 2dup valid-slot-offset? [ [ record-slot-access ] [ copy-slot-value ] 3bi ] - [ [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ] + [ unknown-slot-call ] if ; M: #call escape-analysis* From 361de6c47073ebaa16b95fcf30abfd11ba153211 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Feb 2010 15:29:02 +1300 Subject: [PATCH 14/15] math.points: move to extra --- {basis => extra}/math/points/points.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {basis => extra}/math/points/points.factor (100%) diff --git a/basis/math/points/points.factor b/extra/math/points/points.factor similarity index 100% rename from basis/math/points/points.factor rename to extra/math/points/points.factor From a495f8e0998de845a82c9a7b905cff2e18686bfa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 16 Feb 2010 15:29:46 +1300 Subject: [PATCH 15/15] assocs: move conjoin and conjoin-at to assoc docs --- core/assocs/assocs-docs.factor | 10 +++++++++- core/sets/sets-docs.factor | 2 -- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index ecbc2e6bc7..0d5a884832 100644 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007, 2009 Daniel Ehrenberg, Slava Pestov, and Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences -sequences.private namespaces math quotations assocs.private ; +sequences.private namespaces math quotations assocs.private +sets ; IN: assocs ARTICLE: "alists" "Association lists" @@ -90,6 +91,8 @@ ARTICLE: "assocs-values" "Transposed assoc operations" ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" "It is often useful to use the keys of an associative mapping as a set, exploiting the constant or logarithmic lookup time of most implementations (" { $link "alists" } " being a notable exception)." +$nl +"Set-theoretic operations:" { $subsections assoc-subset? assoc-intersect @@ -98,6 +101,11 @@ ARTICLE: "assocs-sets" "Set-theoretic operations on assocs" substitute extract-keys } +"Adding elements to sets:" +{ $subsections + conjoin + conjoin-at +} "Destructive operations:" { $subsections assoc-union! diff --git a/core/sets/sets-docs.factor b/core/sets/sets-docs.factor index 999e963f36..d9b1271152 100644 --- a/core/sets/sets-docs.factor +++ b/core/sets/sets-docs.factor @@ -29,8 +29,6 @@ $nl "Adding elements to sets:" { $subsections adjoin - conjoin - conjoin-at } { $see-also member? member-eq? any? all? "assocs-sets" } ;