From 68d7137a16dbf3ee2f9543582e771d67cb06b1a0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 24 Apr 2009 02:16:05 -0400 Subject: [PATCH 01/89] Fix minor inconsistency in reference to var name --- extra/benchmark/pidigits/pidigits.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor index 5de5cc5e99..0f8a98e6f9 100644 --- a/extra/benchmark/pidigits/pidigits.factor +++ b/extra/benchmark/pidigits/pidigits.factor @@ -18,7 +18,7 @@ IN: benchmark.pidigits : >matrix ( q s r t -- z ) 4array 2 group ; -: produce ( z n -- z' ) +: produce ( z y -- z' ) [ 10 ] dip -10 * 0 1 >matrix swap m. ; : gen-x ( x -- matrix ) From 9981f6534fd7a9d80abcbdeae45c43438adf2165 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 1 May 2009 20:46:25 -0400 Subject: [PATCH 02/89] Use iota in Project Euler solutions --- extra/project-euler/001/001.factor | 6 +++--- extra/project-euler/005/005.factor | 6 +++--- extra/project-euler/030/030.factor | 2 +- extra/project-euler/048/048.factor | 4 ++-- extra/project-euler/055/055.factor | 2 +- extra/project-euler/057/057.factor | 16 ++++++++-------- 6 files changed, 18 insertions(+), 18 deletions(-) diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 0d4f5fb1bd..e4c8a20cb3 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -1,4 +1,4 @@ -! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov. +! Copyright (c) 2007-2009 Aaron Schaefer, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions math.ranges project-euler.common sequences sets ; @@ -47,14 +47,14 @@ PRIVATE> : euler001b ( -- answer ) - 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; + 1000 iota [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; ! [ euler001b ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) : euler001c ( -- answer ) - 1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ; + 1000 iota [ { 3 5 } [ divisor? ] with any? ] filter sum ; ! [ euler001c ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) diff --git a/extra/project-euler/005/005.factor b/extra/project-euler/005/005.factor index 7fef29a6b9..8512bc97fa 100644 --- a/extra/project-euler/005/005.factor +++ b/extra/project-euler/005/005.factor @@ -1,6 +1,6 @@ -! Copyright (c) 2007 Aaron Schaefer. +! Copyright (c) 2007, 2009 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: math math.functions sequences project-euler.common ; +USING: math math.functions math.ranges project-euler.common sequences ; IN: project-euler.005 ! http://projecteuler.net/index.php?section=problems&id=5 @@ -18,7 +18,7 @@ IN: project-euler.005 ! -------- : euler005 ( -- answer ) - 20 1 [ 1+ lcm ] reduce ; + 20 [1,b] 1 [ lcm ] reduce ; ! [ euler005 ] 100 ave-time ! 0 ms ave run time - 0.14 SD (100 trials) diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor index 54d48660d5..7c8334cfd4 100644 --- a/extra/project-euler/030/030.factor +++ b/extra/project-euler/030/030.factor @@ -38,7 +38,7 @@ IN: project-euler.030 PRIVATE> : euler030 ( -- answer ) - 325537 [ dup sum-fifth-powers = ] filter sum 1- ; + 325537 iota [ dup sum-fifth-powers = ] filter sum 1- ; ! [ euler030 ] 100 ave-time ! 1700 ms ave run time - 64.84 SD (100 trials) diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor index e56b9e9548..640a3a68f6 100644 --- a/extra/project-euler/048/048.factor +++ b/extra/project-euler/048/048.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions sequences project-euler.common ; +USING: kernel math math.functions math.ranges project-euler.common sequences ; IN: project-euler.048 ! http://projecteuler.net/index.php?section=problems&id=48 @@ -17,7 +17,7 @@ IN: project-euler.048 ! -------- : euler048 ( -- answer ) - 1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ; + 1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ; ! [ euler048 ] 100 ave-time ! 276 ms run / 1 ms GC ave time - 100 trials diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor index 43f380b3ba..6154e29717 100644 --- a/extra/project-euler/055/055.factor +++ b/extra/project-euler/055/055.factor @@ -61,7 +61,7 @@ IN: project-euler.055 PRIVATE> : euler055 ( -- answer ) - 10000 [ lychrel? ] count ; + 10000 iota [ lychrel? ] count ; ! [ euler055 ] 100 ave-time ! 478 ms ave run time - 30.63 SD (100 trials) diff --git a/extra/project-euler/057/057.factor b/extra/project-euler/057/057.factor index 681a17dd9e..0c434f4506 100644 --- a/extra/project-euler/057/057.factor +++ b/extra/project-euler/057/057.factor @@ -11,14 +11,14 @@ IN: project-euler.057 ! It is possible to show that the square root of two can be expressed ! as an infinite continued fraction. -! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213... +! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213... ! By expanding this for the first four iterations, we get: -! 1 + 1/2 = 3/2 = 1.5 -! 1 + 1/(2 + 1/2) = 7/5 = 1.4 -! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666... -! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379... +! 1 + 1/2 = 3/2 = 1.5 +! 1 + 1/(2 + 1/2) = 7/5 = 1.4 +! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666... +! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379... ! The next three expansions are 99/70, 239/169, and 577/408, but the ! eighth expansion, 1393/985, is the first example where the number of @@ -35,9 +35,9 @@ IN: project-euler.057 >fraction [ number>string length ] bi@ > ; inline : euler057 ( -- answer ) - 0 1000 [ drop 2 + recip dup 1+ longer-numerator? ] count nip ; + 0 1000 iota [ drop 2 + recip dup 1+ longer-numerator? ] count nip ; -! [ euler057 ] time -! 3.375118 seconds +! [ euler057 ] 100 ave-time +! 1728 ms ave run time - 80.81 SD (100 trials) SOLUTION: euler057 From e59e051c749201d85d754966b10aa2dd65cb636e Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 1 May 2009 22:26:49 -0400 Subject: [PATCH 03/89] Use [0,b) and iota where appropriate --- extra/project-euler/001/001.factor | 4 ++-- extra/project-euler/018/018.factor | 4 ++-- extra/project-euler/027/027.factor | 5 ++--- extra/project-euler/030/030.factor | 4 ++-- extra/project-euler/032/032.factor | 2 +- extra/project-euler/055/055.factor | 4 ++-- extra/project-euler/057/057.factor | 5 +++-- extra/project-euler/150/150.factor | 7 ++++--- 8 files changed, 18 insertions(+), 17 deletions(-) diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index e4c8a20cb3..204527418b 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -47,14 +47,14 @@ PRIVATE> : euler001b ( -- answer ) - 1000 iota [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; + 1000 [0,b) [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; ! [ euler001b ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) : euler001c ( -- answer ) - 1000 iota [ { 3 5 } [ divisor? ] with any? ] filter sum ; + 1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ; ! [ euler001c ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor index 9c7c4fee74..9189323121 100644 --- a/extra/project-euler/018/018.factor +++ b/extra/project-euler/018/018.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math project-euler.common sequences ; +USING: kernel math math.ranges project-euler.common sequences ; IN: project-euler.018 ! http://projecteuler.net/index.php?section=problems&id=18 @@ -66,7 +66,7 @@ IN: project-euler.018 91 71 52 38 17 14 91 43 58 50 27 29 48 63 66 04 68 89 53 67 30 73 16 69 87 40 31 04 62 98 27 23 09 70 98 73 93 38 53 60 04 23 - } 15 iota [ 1+ cut swap ] map nip ; + } 15 [1,b] [ cut swap ] map nip ; PRIVATE> diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor index 4bcfb66a94..f7bffbf665 100644 --- a/extra/project-euler/027/027.factor +++ b/extra/project-euler/027/027.factor @@ -1,7 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.primes project-euler.common sequences -project-euler.common ; +USING: kernel math math.primes math.ranges project-euler.common sequences ; IN: project-euler.027 ! http://projecteuler.net/index.php?section=problems&id=27 @@ -47,7 +46,7 @@ IN: project-euler.027 : euler030 ( -- answer ) - 325537 iota [ dup sum-fifth-powers = ] filter sum 1- ; + 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ; ! [ euler030 ] 100 ave-time ! 1700 ms ave run time - 64.84 SD (100 trials) diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 64c9ec445e..814f8a5a63 100755 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -28,7 +28,7 @@ IN: project-euler.032 : source-032 ( -- seq ) 9 factorial iota [ - 9 permutation [ 1+ ] map 10 digits>integer + 9 permutation [ 1 + ] map 10 digits>integer ] map ; : 1and4 ( n -- ? ) diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor index 6154e29717..07525fe6a4 100644 --- a/extra/project-euler/055/055.factor +++ b/extra/project-euler/055/055.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.parser project-euler.common sequences ; +USING: kernel math math.parser math.ranges project-euler.common sequences ; IN: project-euler.055 ! http://projecteuler.net/index.php?section=problems&id=55 @@ -61,7 +61,7 @@ IN: project-euler.055 PRIVATE> : euler055 ( -- answer ) - 10000 iota [ lychrel? ] count ; + 10000 [0,b) [ lychrel? ] count ; ! [ euler055 ] 100 ave-time ! 478 ms ave run time - 30.63 SD (100 trials) diff --git a/extra/project-euler/057/057.factor b/extra/project-euler/057/057.factor index 0c434f4506..97789944fe 100644 --- a/extra/project-euler/057/057.factor +++ b/extra/project-euler/057/057.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Samuel Tardieu ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.parser sequences project-euler.common ; +USING: kernel math math.functions math.parser math.ranges project-euler.common + sequences ; IN: project-euler.057 ! http://projecteuler.net/index.php?section=problems&id=57 @@ -35,7 +36,7 @@ IN: project-euler.057 >fraction [ number>string length ] bi@ > ; inline : euler057 ( -- answer ) - 0 1000 iota [ drop 2 + recip dup 1+ longer-numerator? ] count nip ; + 0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ; ! [ euler057 ] 100 ave-time ! 1728 ms ave run time - 80.81 SD (100 trials) diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor index 314698534f..eeb4b0c315 100644 --- a/extra/project-euler/150/150.factor +++ b/extra/project-euler/150/150.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2008 Eric Mertens. ! See http://factorcode.org/license.txt for BSD license. -USING: hints kernel locals math math.order sequences sequences.private project-euler.common ; +USING: hints kernel locals math math.order math.ranges project-euler.common + sequences sequences.private ; IN: project-euler.150 ! http://projecteuler.net/index.php?section=problems&id=150 @@ -50,13 +51,13 @@ IN: project-euler.150 615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline : sums-triangle ( -- seq ) - 0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ; + 0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ; :: (euler150) ( m -- n ) [let | table [ sums-triangle ] | m [| x | x 1+ [| y | - m x - iota [| z | + m x - [0,b) [| z | x z + table nth-unsafe [ y z + 1+ swap nth-unsafe ] [ y swap nth-unsafe ] bi - From 17fa5ac5f1c20b1503f43bef37347311787e8b85 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 May 2009 02:06:52 -0400 Subject: [PATCH 04/89] Add deck generation and shuffling to poker vocab --- extra/poker/poker-tests.factor | 2 +- extra/poker/poker.factor | 31 ++++++++++++++++++++++--------- 2 files changed, 23 insertions(+), 10 deletions(-) diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index ad371a6bff..e2d89620e6 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -1,4 +1,4 @@ -USING: accessors poker poker.private tools.test math.order kernel ; +USING: accessors kernel math.order poker poker.private tools.test ; IN: poker.tests [ 134236965 ] [ "KD" >ckf ] unit-test diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index e8e9fa23c5..15e9a96d42 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -1,7 +1,9 @@ -! Copyright (c) 2009 Aaron Schaefer. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors ascii binary-search combinators kernel locals math - math.bitwise math.order poker.arrays sequences splitting ; +! Copyright (c) 2009 Aaron Schaefer. All rights reserved. +! The contents of this file are licensed under the Simplified BSD License +! A copy of the license is available at http://factorcode.org/license.txt +USING: accessors arrays ascii binary-search combinators kernel locals math + math.bitwise math.order poker.arrays random sequences sequences.product + splitting ; IN: poker ! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with @@ -57,6 +59,8 @@ CONSTANT: TWO_PAIR 7 CONSTANT: ONE_PAIR 8 CONSTANT: HIGH_CARD 9 +CONSTANT: SUIT_STR { "C" "D" "H" "S" } + CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" } CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" @@ -108,6 +112,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" #! Cactus Kev Format >upper 1 cut (>ckf) ; +: parse-cards ( str -- seq ) + " " split [ >ckf ] map ; + : flush? ( cards -- ? ) HEX: F000 [ bitand ] reduce 0 = not ; @@ -165,6 +172,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" [ drop STRAIGHT_FLUSH ] ! 10 straight-flushes } cond ; +: card>string ( card -- str ) + [ >card-rank ] [ >card-suit ] bi append ; + PRIVATE> TUPLE: hand @@ -176,13 +186,16 @@ M: hand equal? over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ; : ( str -- hand ) - " " split [ >ckf ] map - dup hand-value hand boa ; + parse-cards dup hand-value hand boa ; : >cards ( hand -- str ) - cards>> [ - [ >card-rank ] [ >card-suit ] bi append - ] map " " join ; + cards>> [ card>string ] map " " join ; : >value ( hand -- str ) hand-rank VALUE_STR nth ; + +: ( -- deck ) + RANK_STR SUIT_STR 2array [ concat >ckf ] product-map ; + +ALIAS: shuffle randomize + From 71022f9940e6e047e8574a972fc98bb030405df0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 5 May 2009 22:43:07 -0400 Subject: [PATCH 05/89] Add combination support to math.combinatorics --- basis/math/combinatorics/combinatorics.factor | 72 ++++++++++++++----- 1 file changed, 56 insertions(+), 16 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index afdf4e378e..0ca306b68c 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,7 +1,7 @@ -! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer. +! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel math math.order math.ranges mirrors -namespaces sequences sorting fry ; +USING: accessors assocs fry kernel locals math math.order math.ranges mirrors + namespaces sequences sorting ; IN: math.combinatorics [ dupd - ] when ; inline -! See this article for explanation of the factoradic-based permutation methodology: -! http://msdn2.microsoft.com/en-us/library/aa302371.aspx +PRIVATE> + +: factorial ( n -- n! ) + 1 [ 1 + * ] reduce ; + +: nPk ( n k -- nPk ) + 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; + +: nCk ( n k -- nCk ) + twiddle [ nPk ] keep factorial / ; + + +! Factoradic-based permutation methodology + + ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ; + 0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ; : (>permutation) ( seq n -- seq ) - [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ; + [ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ; : >permutation ( factoradic -- permutation ) reverse 1 cut [ (>permutation) ] each ; @@ -29,15 +42,6 @@ IN: math.combinatorics PRIVATE> -: factorial ( n -- n! ) - 1 [ 1+ * ] reduce ; - -: nPk ( n k -- nPk ) - 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ; - -: nCk ( n k -- nCk ) - twiddle [ nPk ] keep factorial / ; - : permutation ( n seq -- seq ) [ permutation-indices ] keep nths ; @@ -53,3 +57,39 @@ PRIVATE> : inverse-permutation ( seq -- permutation ) >alist sort-values keys ; + + +! Combinadic-based combination methodology + +TUPLE: combination + { n integer } + { k integer } ; + +C: combination + +> ] [ k>> ] bi nCk 1 - ] dip - ; + +: largest-value ( a b x -- v ) + #! TODO: use a binary search instead of find-last + [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ; + +:: next-values ( a b x -- a' b' x' v ) + a b x largest-value dup :> v ! a' + b 1 - ! b' + x v b nCk - ! x' + v ; ! v == a' + +: initial-values ( combination m -- a b x ) + [ [ n>> ] [ k>> ] [ ] tri ] dip dual-index ; + +: combinadic ( combination m -- combinadic ) + initial-values [ over 0 > ] [ next-values ] produce + [ 3drop ] dip ; + +PRIVATE> + +: combination ( m combination -- seq ) + swap [ drop n>> 1 - ] [ combinadic ] 2bi [ - ] with map ; From eaeda30bb1f586d2c18e4d5804055ac1423c81cf Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 01:17:35 -0400 Subject: [PATCH 06/89] Combinations now map to input sequences directly --- basis/math/combinatorics/combinatorics.factor | 47 +++++++++++++------ 1 file changed, 33 insertions(+), 14 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 0ca306b68c..dd71ded8c2 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -52,7 +52,7 @@ PRIVATE> [ [ length factorial ] keep ] dip '[ _ permutation @ ] each ; inline -: reduce-permutations ( seq initial quot -- result ) +: reduce-permutations ( seq identity quot -- result ) swapd each-permutation ; inline : inverse-permutation ( seq -- permutation ) @@ -61,16 +61,13 @@ PRIVATE> ! Combinadic-based combination methodology -TUPLE: combination - { n integer } - { k integer } ; - -C: combination - > ] [ k>> ] bi nCk 1 - ] dip - ; +TUPLE: combo + { seq sequence } + { k integer } ; + +C: combo : largest-value ( a b x -- v ) #! TODO: use a binary search instead of find-last @@ -82,14 +79,36 @@ C: combination x v b nCk - ! x' v ; ! v == a' -: initial-values ( combination m -- a b x ) - [ [ n>> ] [ k>> ] [ ] tri ] dip dual-index ; +: dual-index ( combo m -- x ) + [ [ seq>> length ] [ k>> ] bi nCk 1 - ] dip - ; -: combinadic ( combination m -- combinadic ) +: initial-values ( combo m -- a b x ) + [ [ seq>> length ] [ k>> ] [ ] tri ] dip dual-index ; + +: combinadic ( combo m -- combinadic ) initial-values [ over 0 > ] [ next-values ] produce [ 3drop ] dip ; +: combination-indices ( m combo -- seq ) + [ swap combinadic ] keep + seq>> length 1 - swap [ - ] with map ; + +: apply-combination ( m combo -- seq ) + [ combination-indices ] keep seq>> nths ; + +: choose ( combo -- nCk ) + [ seq>> length ] [ k>> ] bi nCk ; + PRIVATE> -: combination ( m combination -- seq ) - swap [ drop n>> 1 - ] [ combinadic ] 2bi [ - ] with map ; +: combination ( m seq k -- seq ) + apply-combination ; + +: all-combinations ( seq k -- seq ) + [ choose [0,b) ] keep + '[ _ apply-combination ] map ; + +: each-combination ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] each ; inline + From c88fc97f37ac7a9e3b871c92c37a42cbbed338a6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 May 2009 14:38:38 -0500 Subject: [PATCH 07/89] document ${ --- basis/literals/literals-docs.factor | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/basis/literals/literals-docs.factor b/basis/literals/literals-docs.factor index 0d61dcb467..9dd398d962 100644 --- a/basis/literals/literals-docs.factor +++ b/basis/literals/literals-docs.factor @@ -21,7 +21,7 @@ CONSTANT: five 5 USING: kernel literals prettyprint ; IN: scratchpad -<< : seven-eleven ( -- a b ) 7 11 ; >> +: seven-eleven ( -- a b ) 7 11 ; { $ seven-eleven } . "> "{ 7 11 }" } @@ -43,7 +43,24 @@ IN: scratchpad } ; -{ POSTPONE: $ POSTPONE: $[ } related-words +HELP: ${ +{ $syntax "${ code }" } +{ $description "Outputs an array containing the results of executing " { $snippet "code" } " at parse time." } +{ $notes { $snippet "code" } "'s definition is looked up and " { $link call } "ed at parse time, so words that reference words in the current compilation unit cannot be used with " { $snippet "$" } "." } +{ $examples + + { $example <" +USING: kernel literals math prettyprint ; +IN: scratchpad + +CONSTANT: five 5 +CONSTANT: six 6 +${ five six 7 } . + "> "{ 5 6 7 }" + } +} ; + +{ POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words ARTICLE: "literals" "Interpolating code results into literal values" "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values." @@ -51,11 +68,12 @@ ARTICLE: "literals" "Interpolating code results into literal values" USING: kernel literals math prettyprint ; IN: scratchpad -<< CONSTANT: five 5 >> +CONSTANT: five 5 { $ five $[ five dup 1+ dup 2 + ] } . "> "{ 5 5 6 8 }" } { $subsection POSTPONE: $ } { $subsection POSTPONE: $[ } +{ $subsection POSTPONE: ${ } ; ABOUT: "literals" From 05b49e15e0dfef5cc2e542c55fe4bc2558f6bfe3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 14:56:50 -0500 Subject: [PATCH 08/89] tools.time: remove unneeded math.vectors dependency --- basis/tools/time/time.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 65e87f976f..948c0d482d 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.vectors memory io io.styles prettyprint +USING: kernel math memory io io.styles prettyprint namespaces system sequences splitting grouping assocs strings generic.single combinators ; IN: tools.time From 867ff51b83701440274f30b418aa4428903236f5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 14:57:17 -0500 Subject: [PATCH 09/89] Remove some unused constants and update an obsolete comment --- basis/cpu/x86/bootstrap.factor | 2 +- vm/cpu-x86.32.S | 1 - vm/cpu-x86.64.S | 1 - 3 files changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index fcd8ed0eee..fc7fbc88b9 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -194,7 +194,7 @@ big-endian off [ ! Untag temp0 temp0 tag-mask get bitnot AND - ! Set temp1 to 0 for objects, and 8 for tuples + ! Set temp1 to 0 for objects, and bootstrap-cell for tuples temp1 1 tag-fixnum AND bootstrap-cell 4 = [ temp1 1 SHR ] when ! Load header cell or tuple layout cell diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 3c0db36935..0c08ea7b46 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -30,7 +30,6 @@ and the callstack top is passed in EDX */ pop %ebx #define QUOT_XT_OFFSET 16 -#define WORD_XT_OFFSET 30 /* 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 a110bf1d51..5a70280ddf 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -62,7 +62,6 @@ #endif #define QUOT_XT_OFFSET 36 -#define WORD_XT_OFFSET 66 /* 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 From 688cd9b79bacba079313a3a8aa91f61117c6a656 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 15:30:30 -0500 Subject: [PATCH 10/89] hashtables: use each-integer instead of iota ... each in >alist --- core/hashtables/hashtables.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor index 0914134bb6..03bc3e01fd 100644 --- a/core/hashtables/hashtables.factor +++ b/core/hashtables/hashtables.factor @@ -139,14 +139,14 @@ M: hashtable set-at ( value key hash -- ) PRIVATE> M: hashtable >alist - [ array>> [ length 2/ iota ] keep ] [ assoc-size ] bi [ + [ array>> [ length 2/ ] keep ] [ assoc-size ] bi [ [ [ [ 1 fixnum-shift-fast ] dip [ array-nth ] [ [ 1 fixnum+fast ] dip array-nth ] 2bi ] dip pick tombstone? [ 3drop ] [ [ 2array ] dip push-unsafe ] if - ] 2curry each + ] 2curry each-integer ] keep { } like ; M: hashtable clone From bf887cf02854083cd2433aa9ce289d22cc70dc79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 15:30:52 -0500 Subject: [PATCH 11/89] cpu.ppc.bootstrap: working on polymorphic inline caching for PowerPC --- basis/cpu/ppc/bootstrap.factor | 108 +++++++++++++++++++++++++++++---- 1 file changed, 97 insertions(+), 11 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 7278fd2092..5451cf2b79 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -9,8 +9,8 @@ IN: bootstrap.ppc 4 \ cell set big-endian on -CONSTANT: ds-reg 29 -CONSTANT: rs-reg 30 +CONSTANT: ds-reg 13 +CONSTANT: rs-reg 14 : factor-area-size ( -- n ) 4 bootstrap-cells ; @@ -138,6 +138,16 @@ CONSTANT: rs-reg 30 jit-3r> ] jit-3dip jit-define +: prepare-(execute) ( -- operand ) + 3 ds-reg 0 LWZ + ds-reg dup 4 SUBI + 4 3 word-xt-offset LWZ + 4 ; + +[ prepare-(execute) MTCTR BCTR ] jit-execute-jump jit-define + +[ prepare-(execute) MTLR BLRL ] jit-execute-call jit-define + [ 0 1 lr-save stack-frame + LWZ 1 1 stack-frame ADDI @@ -146,7 +156,91 @@ CONSTANT: rs-reg 30 [ BLR ] jit-return jit-define -! Sub-primitives +! ! ! Polymorphic inline caches + +! Load a value from a stack position +[ + 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel +] pic-load jit-define + +! Tag +: load-tag ( -- ) + 4 4 tag-mask get ANDI + 4 4 tag-bits get SLWI ; + +[ load-tag ] pic-tag jit-define + +! Hi-tag +[ + 3 4 MR + load-tag + 0 4 object tag-number tag-fixnum CMPI + 2 BNE + 4 3 object tag-number neg LWZ +] pic-hi-tag jit-define + +! Tuple +[ + 3 4 MR + load-tag + 0 4 tuple tag-number tag-fixnum CMPI + 2 BNE + 4 3 tuple tag-number neg bootstrap-cell + LWZ +] pic-tuple jit-define + +! Hi-tag and tuple +[ + 3 4 MR + load-tag + ! If bits 2 and 3 are set, the tag is either 6 (object) or 7 (tuple) + 0 4 BIN: 110 tag-fixnum CMPI + 5 BLT + ! Untag r3 + 3 3 0 0 31 tag-bits get - RLWINM + ! Set r4 to 0 for objects, and bootstrap-cell for tuples + 4 4 1 tag-fixnum ANDI + 4 4 1 SRAWI + ! Load header cell or tuple layout cell + 4 4 3 LWZX +] pic-hi-tag-tuple jit-define + +[ + 0 4 0 CMPI rc-absolute-ppc-2 rt-immediate jit-rel +] pic-check-tag jit-define + +[ + 0 5 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 4 0 5 CMP +] pic-check jit-define + +[ 2 BNE 0 B rc-relative-ppc-3 rt-xt jit-rel ] pic-hit jit-define + +! ! ! Megamorphic caches + +[ + ! cache = ... + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + ! key = class + 5 4 MR + ! key &= cache.length - 1 + 5 5 mega-cache-size get 1- bootstrap-cell * ANDI + ! cache += array-start-offset + 3 3 array-start-offset ADDI + ! cache += key + 3 3 5 ADD + ! if(get(cache) == class) + 6 3 0 LWZ + 6 0 4 CMP + 5 BNE + ! ... goto get(cache + bootstrap-cell) + 3 3 4 LWZ + 3 3 word-xt-offset LWZ + 3 MTCTR + BCTR + ! fall-through on miss +] mega-lookup jit-define + +! ! ! Sub-primitives ! Quotations and words [ @@ -157,14 +251,6 @@ CONSTANT: rs-reg 30 BCTR ] \ (call) define-sub-primitive -[ - 3 ds-reg 0 LWZ - ds-reg dup 4 SUBI - 4 3 word-xt-offset LWZ - 4 MTCTR - BCTR -] \ (execute) define-sub-primitive - ! Objects [ 3 ds-reg 0 LWZ From 49409b4d8cf10ee7f11fed366f8800e7593758e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 15:39:03 -0500 Subject: [PATCH 12/89] Working on PowerPC backend --- basis/cpu/ppc/ppc.factor | 25 +++++++------ vm/cpu-ppc.S | 76 ++++++++++++++++++++++------------------ vm/cpu-ppc.hpp | 60 ++++++++++++++++++++++++++----- vm/inline_cache.cpp | 2 ++ 4 files changed, 107 insertions(+), 56 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 85bf188bb8..a6beb42399 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -1,20 +1,19 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words -alien alien.c-types cpu.architecture cpu.ppc.assembler -compiler.cfg.registers compiler.cfg.instructions +alien alien.c-types literals cpu.architecture cpu.ppc.assembler +literals compiler.cfg.registers compiler.cfg.instructions compiler.constants compiler.codegen compiler.codegen.fixup compiler.cfg.intrinsics compiler.cfg.stack-frame ; IN: cpu.ppc ! PowerPC register assignments: -! r2-r27: integer vregs -! r28: integer scratch -! r29: data stack -! r30: retain stack +! r2-r12: integer vregs +! r15-r29 +! r30: integer scratch ! f0-f29: float vregs -! f30, f31: float scratch +! f30: float scratch enable-float-intrinsics @@ -23,11 +22,11 @@ enable-float-intrinsics M: ppc machine-registers { - { int-regs T{ range f 2 26 1 } } - { double-float-regs T{ range f 0 29 1 } } + { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] } + { double-float-regs $[ 0 29 [a,b] ] } } ; -CONSTANT: scratch-reg 28 +CONSTANT: scratch-reg 30 CONSTANT: fp-scratch-reg 30 M: ppc two-operand? f ; @@ -40,8 +39,8 @@ M: ppc %load-reference ( reg obj -- ) M: ppc %alien-global ( register symbol dll -- ) [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ; -CONSTANT: ds-reg 29 -CONSTANT: rs-reg 30 +CONSTANT: ds-reg 13 +CONSTANT: rs-reg 14 GENERIC: loc-reg ( loc -- reg ) diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 5e77c004aa..f8dad4b2b2 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -2,7 +2,7 @@ in the public domain. */ #include "asm.h" -#define DS_REG r29 +#define DS_REG r13 DEF(void,primitive_fixnum_add,(void)): lwz r3,0(DS_REG) @@ -45,7 +45,7 @@ multiply_overflow: /* Note that the XT is passed to the quotation in r11 */ #define CALL_OR_JUMP_QUOT \ - lwz r11,14(r3) /* load quotation-xt slot */ XX \ + lwz r11,16(r3) /* load quotation-xt slot */ XX \ #define CALL_QUOT \ CALL_OR_JUMP_QUOT XX \ @@ -100,22 +100,22 @@ the Factor compiler treats the entire register file as volatile. */ DEF(void,c_to_factor,(CELL quot)): PROLOGUE - SAVE_INT(r13,0) /* save GPRs */ - SAVE_INT(r14,1) - SAVE_INT(r15,2) - SAVE_INT(r16,3) - SAVE_INT(r17,4) - SAVE_INT(r18,5) - SAVE_INT(r19,6) - SAVE_INT(r20,7) - SAVE_INT(r21,8) - SAVE_INT(r22,9) - SAVE_INT(r23,10) - SAVE_INT(r24,11) - SAVE_INT(r25,12) - SAVE_INT(r26,13) - SAVE_INT(r27,14) - SAVE_INT(r28,15) + SAVE_INT(r15,0) /* save GPRs */ + SAVE_INT(r16,1) + SAVE_INT(r17,2) + SAVE_INT(r18,3) + SAVE_INT(r19,4) + SAVE_INT(r20,5) + SAVE_INT(r21,6) + SAVE_INT(r22,7) + SAVE_INT(r23,8) + SAVE_INT(r24,9) + SAVE_INT(r25,10) + SAVE_INT(r26,11) + SAVE_INT(r27,12) + SAVE_INT(r28,13) + SAVE_INT(r29,14) + SAVE_INT(r30,15) SAVE_INT(r31,16) SAVE_FP(f14,20) /* save FPRs */ @@ -165,22 +165,22 @@ DEF(void,c_to_factor,(CELL quot)): RESTORE_FP(f14,20) /* save FPRs */ RESTORE_INT(r31,16) /* restore GPRs */ - RESTORE_INT(r28,15) - RESTORE_INT(r27,14) - RESTORE_INT(r26,13) - RESTORE_INT(r25,12) - RESTORE_INT(r24,11) - RESTORE_INT(r23,10) - RESTORE_INT(r22,9) - RESTORE_INT(r21,8) - RESTORE_INT(r20,7) - RESTORE_INT(r19,6) - RESTORE_INT(r18,5) - RESTORE_INT(r17,4) - RESTORE_INT(r16,3) - RESTORE_INT(r15,2) - RESTORE_INT(r14,1) - RESTORE_INT(r13,0) + RESTORE_INT(r30,15) + RESTORE_INT(r29,14) + RESTORE_INT(r28,13) + RESTORE_INT(r27,12) + RESTORE_INT(r26,11) + RESTORE_INT(r25,10) + RESTORE_INT(r24,9) + RESTORE_INT(r23,8) + RESTORE_INT(r22,7) + RESTORE_INT(r21,6) + RESTORE_INT(r20,5) + RESTORE_INT(r19,4) + RESTORE_INT(r18,3) + RESTORE_INT(r17,2) + RESTORE_INT(r16,1) + RESTORE_INT(r15,0) EPILOGUE blr @@ -234,3 +234,11 @@ DEF(void,flush_icache,(void *start, int len)): sync /* finish up */ isync blr + +DEF(void,primitive_inline_cache_miss,(void)): + mflr r3 + PROLOGUE + bl MANGLE(inline_cache_miss) + EPILOGUE + mtctr r3 + bctr diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index 7e8ae05fac..d393223d8d 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -2,16 +2,58 @@ namespace factor { #define FACTOR_CPU_STRING "ppc" -#define VM_ASM_API +#define VM_ASM_API VM_C_API -register cell ds asm("r29"); -register cell rs asm("r30"); +register cell ds asm("r13"); +register cell rs asm("r14"); -void c_to_factor(cell quot); -void undefined(cell word); -void set_callstack(stack_frame *to, stack_frame *from, cell length, void *memcpy); -void throw_impl(cell quot, stack_frame *rewind); -void lazy_jit_compile(cell quot); -void flush_icache(cell start, cell len); +inline static void check_call_site(cell return_address) +{ +#ifdef FACTOR_DEBUG + cell insn = *(cell *)return_address; + assert((insn & 0x3) == 0x1); + assert((insn >> 26) == 0x12); +#endif +} + +#define B_MASK 0x3fffffc + +inline static void *get_call_target(cell return_address) +{ + return_address -= sizeof(cell); + + check_call_site(return_address); + cell insn = *(cell *)return_address; + cell unsigned_addr = (insn & B_MASK); + fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6; + return (void *)(signed_addr + return_address); +} + +inline static void set_call_target(cell return_address, void *target) +{ + return_address -= sizeof(cell); + +#ifdef FACTOR_DEBUG + assert((return_address & ~B_MASK) == 0); + check_call_site(return_address); +#endif + cell insn = *(cell *)return_address; + insn = ((insn & ~B_MASK) | (((cell)target - return_address) & B_MASK)); + *(cell *)return_address = insn; + + /* Flush the cache line containing the call we just patched */ + __asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):); +} + +/* Defined in assembly */ +VM_ASM_API void c_to_factor(cell quot); +VM_ASM_API void throw_impl(cell quot, stack_frame *rewind); +VM_ASM_API void lazy_jit_compile(cell quot); +VM_ASM_API void flush_icache(cell start, cell len); + +VM_ASM_API void set_callstack(stack_frame *to, + stack_frame *from, + cell length, + void *(*memcpy)(void*,const void*, size_t)); } diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index 259a3e0c77..59632c4185 100755 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -21,6 +21,8 @@ void deallocate_inline_cache(cell return_address) { /* Find the call target. */ void *old_xt = get_call_target(return_address); + check_code_pointer((cell)old_xt); + code_block *old_block = (code_block *)old_xt - 1; cell old_type = old_block->type; From 215d21c2bd0104a71da7da0cc37406c52266ae16 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 6 May 2009 15:49:29 -0500 Subject: [PATCH 13/89] rename perlin-noise to noise; add words for uniform and normal noise --- .../noise.factor} | 62 +++++++++++++++---- 1 file changed, 50 insertions(+), 12 deletions(-) rename extra/{perlin-noise/perlin-noise.factor => noise/noise.factor} (55%) diff --git a/extra/perlin-noise/perlin-noise.factor b/extra/noise/noise.factor similarity index 55% rename from extra/perlin-noise/perlin-noise.factor rename to extra/noise/noise.factor index 0a12eef12c..f2ca8ad59b 100644 --- a/extra/perlin-noise/perlin-noise.factor +++ b/extra/noise/noise.factor @@ -1,11 +1,14 @@ -USING: byte-arrays combinators images kernel locals math math.affine-transforms -math.functions math.polynomials math.vectors random sequences -sequences.product ; -IN: perlin-noise +USING: byte-arrays combinators fry images kernel locals math +math.affine-transforms math.functions math.order +math.polynomials math.vectors random random.mersenne-twister +sequences sequences.product ; +IN: noise -: ( -- table ) +: ( -- table ) 256 iota >byte-array randomize dup append ; + ] dip with-random ; inline + +: >byte-map ( floats -- bytes ) + [ 255.0 * >fixnum ] B{ } map-as ; + +: >image ( bytes dim -- image ) + swap [ L f ] dip image boa ; + +PRIVATE> + +:: perlin-noise ( table point -- value ) point unit-cube :> cube point dup vfloor v- :> gradients gradients fade :> faded @@ -70,14 +84,38 @@ IN: perlin-noise [ faded second lerp ] 2bi@ faded third lerp ; -: noise-map ( table transform dim -- map ) - [ iota ] map [ a.v 0.0 suffix noise ] with with product-map ; - : normalize-0-1 ( sequence -- sequence' ) [ supremum ] [ infimum [ - ] keep ] [ ] tri [ swap - ] with map [ swap / ] with map ; -: noise-image ( table transform dim -- image ) - [ noise-map normalize-0-1 [ 255.0 * >fixnum ] B{ } map-as ] - [ swap [ L f ] dip image boa ] bi ; +: clamp-0-1 ( sequence -- sequence' ) + [ 0.0 max 1.0 min ] map ; +: perlin-noise-map ( table transform dim -- map ) + [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ; + +: perlin-noise-byte-map ( table transform dim -- map ) + perlin-noise-map normalize-0-1 >byte-map ; + +: perlin-noise-image ( table transform dim -- image ) + [ perlin-noise-byte-map ] [ >image ] bi ; + +: uniform-noise-map ( seed dim -- map ) + [ product [ 0.0 1.0 uniform-random-float ] replicate ] + curry with-seed ; + +: uniform-noise-byte-map ( seed dim -- map ) + uniform-noise-map >byte-map ; + +: uniform-noise-image ( seed dim -- image ) + [ uniform-noise-byte-map ] [ >image ] bi ; + +: normal-noise-map ( seed sigma dim -- map ) + swap '[ _ product [ 0.5 _ normal-random-float ] replicate ] + with-seed ; + +: normal-noise-byte-map ( seed sigma dim -- map ) + normal-noise-map clamp-0-1 >byte-map ; + +: normal-noise-image ( seed sigma dim -- image ) + [ normal-noise-byte-map ] [ >image ] bi ; From c93d8760752ad31937ea2a19ce4f2c6da63ad43d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 16:14:53 -0500 Subject: [PATCH 14/89] Better separation of concerns: cpu.{x86,ppc}.assembler no longer depends on compiler.codegen.fixup and cpu.architecture. Rename rt-xt-direct to rt-xt-pic to better explain its purpose --- basis/compiler/codegen/codegen.factor | 2 +- basis/compiler/codegen/fixup/fixup.factor | 4 +-- basis/compiler/constants/constants.factor | 2 +- basis/cpu/architecture/architecture.factor | 1 + basis/cpu/ppc/assembler/assembler.factor | 4 +-- .../cpu/ppc/assembler/backend/backend.factor | 14 +++------ basis/cpu/ppc/bootstrap.factor | 2 +- basis/cpu/ppc/ppc.factor | 13 ++++++-- basis/cpu/x86/32/32.factor | 4 +-- basis/cpu/x86/32/bootstrap.factor | 2 +- basis/cpu/x86/assembler/assembler.factor | 30 +++++-------------- basis/cpu/x86/bootstrap.factor | 16 +++++----- basis/cpu/x86/x86.factor | 9 ++++-- 13 files changed, 48 insertions(+), 55 deletions(-) diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 826fa87b73..47593878fa 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -88,7 +88,7 @@ M: ##call generate-insn word>> dup sub-primitive>> [ first % ] [ [ add-call ] [ %call ] bi ] ?if ; -M: ##jump generate-insn word>> [ add-call ] [ %jump-label ] bi ; +M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ; M: ##return generate-insn drop %return ; diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index 99f258d93c..b52bb51b26 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -56,8 +56,8 @@ SYMBOL: literal-table : rel-word ( word class -- ) [ add-literal ] dip rt-xt rel-fixup ; -: rel-word-direct ( word class -- ) - [ add-literal ] dip rt-xt-direct rel-fixup ; +: rel-word-pic ( word class -- ) + [ add-literal ] dip rt-xt-pic rel-fixup ; : rel-primitive ( word class -- ) [ def>> first add-literal ] dip rt-primitive rel-fixup ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index e30cc10ee2..886933b5cd 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -42,7 +42,7 @@ CONSTANT: rt-primitive 0 CONSTANT: rt-dlsym 1 CONSTANT: rt-dispatch 2 CONSTANT: rt-xt 3 -CONSTANT: rt-xt-direct 4 +CONSTANT: rt-xt-pic 4 CONSTANT: rt-here 5 CONSTANT: rt-this 6 CONSTANT: rt-immediate 7 diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 2c9675426b..de5d1da4e0 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -47,6 +47,7 @@ HOOK: %inc-r cpu ( n -- ) HOOK: stack-frame-size cpu ( stack-frame -- n ) HOOK: %call cpu ( word -- ) +HOOK: %jump cpu ( word -- ) HOOK: %jump-label cpu ( label -- ) HOOK: %return cpu ( -- ) diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor index fbb878a888..2daf3678ce 100644 --- a/basis/cpu/ppc/assembler/assembler.factor +++ b/basis/cpu/ppc/assembler/assembler.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.codegen.fixup kernel namespaces words -io.binary math math.order cpu.ppc.assembler.backend ; +USING: kernel namespaces words io.binary math math.order +cpu.ppc.assembler.backend ; IN: cpu.ppc.assembler ! See the Motorola or IBM documentation for details. The opcode diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor index 946aca6990..1e6365b1e7 100644 --- a/basis/cpu/ppc/assembler/backend/backend.factor +++ b/basis/cpu/ppc/assembler/backend/backend.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: compiler.codegen.fixup cpu.architecture -compiler.constants kernel namespaces make sequences words math -math.bitwise io.binary parser lexer ; +USING: kernel namespaces make sequences words math +math.bitwise io.binary parser lexer fry ; IN: cpu.ppc.assembler.backend : insn ( operand opcode -- ) { 26 0 } bitfield 4 >be % ; @@ -74,21 +73,16 @@ SYNTAX: XO1: (XO) (1) (( a s -- )) define-declared ; GENERIC# (B) 2 ( dest aa lk -- ) M: integer (B) 18 i-insn ; -M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ; -M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; GENERIC: BC ( a b c -- ) M: integer BC 0 0 16 b-insn ; -M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ; -M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; : CREATE-B ( -- word ) scan "B" prepend create-in ; SYNTAX: BC: CREATE-B scan-word scan-word - [ rot BC ] 2curry (( c -- )) define-declared ; + '[ [ _ _ ] dip BC ] (( c -- )) define-declared ; SYNTAX: B: CREATE-B scan-word scan-word scan-word scan-word scan-word - [ b-insn ] curry curry curry curry curry - (( bo -- )) define-declared ; + '[ _ _ _ _ _ b-insn ] (( bo -- )) define-declared ; diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 5451cf2b79..8001868e0c 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -58,7 +58,7 @@ CONSTANT: rs-reg 14 BCTR ] jit-primitive jit-define -[ 0 BL rc-relative-ppc-3 rt-xt-direct jit-rel ] jit-word-call jit-define +[ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define [ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index a6beb42399..c239bacbc0 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -15,10 +15,16 @@ IN: cpu.ppc ! f0-f29: float vregs ! f30: float scratch +! Add some methods to the assembler that are useful to us +M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ; +M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ; + enable-float-intrinsics -<< \ ##integer>float t frame-required? set-word-prop -\ ##float>integer t frame-required? set-word-prop >> +<< +\ ##integer>float t frame-required? set-word-prop +\ ##float>integer t frame-required? set-word-prop +>> M: ppc machine-registers { @@ -107,7 +113,8 @@ M: ppc stack-frame-size ( stack-frame -- i ) factor-area-size + 4 cells align ; -M: ppc %call ( label -- ) BL ; +M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; +M: ppc %jump ( word -- ) 0 B rc-relative-ppc-3 rel-word ; M: ppc %jump-label ( label -- ) B ; M: ppc %return ( -- ) BLR ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 10cd9c8657..376edeb202 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -44,9 +44,9 @@ M: x86.32 param-reg-2 EDX ; M: x86.32 reserved-area-size 0 ; -M: x86.32 %alien-invoke (CALL) rel-dlsym ; +M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; -M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; +M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ; M: x86.32 return-struct-in-registers? ( c-type -- ? ) c-type diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index be21344815..660a428dfb 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -29,7 +29,7 @@ IN: bootstrap.x86 ] jit-save-stack jit-define [ - (JMP) drop rc-relative rt-primitive jit-rel + 0 JMP rc-relative rt-primitive jit-rel ] jit-primitive jit-define << "vocab:cpu/x86/bootstrap.factor" parse-file parsed >> diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 5560d17a1e..2b40aa2053 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -1,12 +1,11 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays cpu.architecture compiler.constants -compiler.codegen.fixup io.binary kernel combinators -kernel.private math namespaces make sequences words system -layouts math.order accessors cpu.x86.assembler.syntax ; +USING: arrays io.binary kernel combinators +kernel.private math namespaces make sequences words system layouts +math.order accessors cpu.x86.assembler.syntax ; IN: cpu.x86.assembler -! A postfix assembler for x86 and AMD64. +! A postfix assembler for x86-32 and x86-64. ! In 32-bit mode, { 1234 } is absolute indirect addressing. ! In 64-bit mode, { 1234 } is RIP-relative. @@ -296,36 +295,23 @@ M: operand (MOV-I) { BIN: 000 t HEX: c6 } pick byte? [ immediate-1 ] [ immediate-4 ] if ; -PREDICATE: callable < word register? not ; - GENERIC: MOV ( dst src -- ) M: immediate MOV swap (MOV-I) ; -M: callable MOV [ 0 ] 2dip (MOV-I) rc-absolute-cell rel-word ; M: operand MOV HEX: 88 2-operand ; : LEA ( dst src -- ) swap HEX: 8d 2-operand ; ! Control flow GENERIC: JMP ( op -- ) -: (JMP) ( -- rel-class ) HEX: e9 , 0 4, rc-relative ; -M: f JMP (JMP) 2drop ; -M: callable JMP (JMP) rel-word ; -M: label JMP (JMP) label-fixup ; +M: integer JMP HEX: e9 , 4, ; M: operand JMP { BIN: 100 t HEX: ff } 1-operand ; GENERIC: CALL ( op -- ) -: (CALL) ( -- rel-class ) HEX: e8 , 0 4, rc-relative ; -M: f CALL (CALL) 2drop ; -M: callable CALL (CALL) rel-word-direct ; -M: label CALL (CALL) label-fixup ; +M: integer CALL HEX: e8 , 4, ; M: operand CALL { BIN: 010 t HEX: ff } 1-operand ; GENERIC# JUMPcc 1 ( addr opcode -- ) -: (JUMPcc) ( addr n -- rel-class ) extended-opcode, 4, rc-relative ; -M: f JUMPcc [ 0 ] dip (JUMPcc) 2drop ; -M: integer JUMPcc (JUMPcc) drop ; -M: callable JUMPcc [ 0 ] dip (JUMPcc) rel-word ; -M: label JUMPcc [ 0 ] dip (JUMPcc) label-fixup ; +M: integer JUMPcc extended-opcode, 4, ; : JO ( dst -- ) HEX: 80 JUMPcc ; : JNO ( dst -- ) HEX: 81 JUMPcc ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index fc7fbc88b9..4b409102c9 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -42,11 +42,11 @@ big-endian off ] jit-push-immediate jit-define [ - f JMP rc-relative rt-xt jit-rel + 0 JMP rc-relative rt-xt jit-rel ] jit-word-jump jit-define [ - f CALL rc-relative rt-xt-direct jit-rel + 0 CALL rc-relative rt-xt-pic jit-rel ] jit-word-call jit-define [ @@ -57,12 +57,12 @@ big-endian off ! compare boolean with f temp0 \ f tag-number CMP ! jump to true branch if not equal - f JNE rc-relative rt-xt jit-rel + 0 JNE rc-relative rt-xt jit-rel ] jit-if-1 jit-define [ ! jump to false branch if equal - f JMP rc-relative rt-xt jit-rel + 0 JMP rc-relative rt-xt jit-rel ] jit-if-2 jit-define : jit->r ( -- ) @@ -115,19 +115,19 @@ big-endian off [ jit->r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-r> ] jit-dip jit-define [ jit-2>r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-2r> ] jit-2dip jit-define [ jit-3>r - f CALL rc-relative rt-xt jit-rel + 0 CALL rc-relative rt-xt jit-rel jit-3r> ] jit-3dip jit-define @@ -211,7 +211,7 @@ big-endian off temp1 temp2 CMP ] pic-check jit-define -[ f JE rc-relative rt-xt jit-rel ] pic-hit jit-define +[ 0 JE rc-relative rt-xt jit-rel ] pic-hit jit-define ! ! ! Megamorphic caches diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 2859e71be2..d508d7740b 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -11,6 +11,10 @@ IN: cpu.x86 << enable-fixnum-log2 >> +! Add some methods to the assembler to be more useful to the backend +M: label JMP 0 JMP rc-relative label-fixup ; +M: label JUMPcc [ 0 ] dip JUMPcc rc-relative label-fixup ; + M: x86 two-operand? t ; HOOK: temp-reg-1 cpu ( -- reg ) @@ -53,8 +57,9 @@ M: x86 stack-frame-size ( stack-frame -- i ) reserved-area-size + align-stack ; -M: x86 %call ( label -- ) CALL ; -M: x86 %jump-label ( label -- ) JMP ; +M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; +M: x86 %jump ( word -- ) 0 JMP rc-relative rel-word ; +M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ; M: x86 %return ( -- ) 0 RET ; : code-alignment ( align -- n ) From 6a19cae3020e43b9c1375ad908bfb909cdd190cb Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 May 2009 16:26:06 -0500 Subject: [PATCH 15/89] Document miller-rabin, more unit tests for some corner cases --- .../miller-rabin/miller-rabin-docs.factor | 100 ++++++++++++++++++ .../miller-rabin/miller-rabin-tests.factor | 12 ++- basis/math/miller-rabin/miller-rabin.factor | 40 +++---- 3 files changed, 133 insertions(+), 19 deletions(-) create mode 100644 basis/math/miller-rabin/miller-rabin-docs.factor diff --git a/basis/math/miller-rabin/miller-rabin-docs.factor b/basis/math/miller-rabin/miller-rabin-docs.factor new file mode 100644 index 0000000000..4aa318f674 --- /dev/null +++ b/basis/math/miller-rabin/miller-rabin-docs.factor @@ -0,0 +1,100 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel sequences math ; +IN: math.miller-rabin + +HELP: find-relative-prime +{ $values + { "n" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ; + +HELP: find-relative-prime* +{ $values + { "n" integer } { "guess" integer } + { "p" integer } +} +{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ; + +HELP: miller-rabin +{ $values + { "n" integer } + { "?" "a boolean" } +} +{ $description "Returns true if the number is a prime. Calls " { $link miller-rabin* } " with a default of 10 Miller-Rabin tests." } ; + +{ miller-rabin miller-rabin* } related-words + +HELP: miller-rabin* +{ $values + { "n" integer } { "numtrials" integer } + { "?" "a boolean" } +} +{ $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ; + +HELP: next-prime +{ $values + { "n" integer } + { "p" integer } +} +{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ; + +HELP: next-safe-prime +{ $values + { "n" integer } + { "q" integer } +} +{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ; + +HELP: random-bits* +{ $values + { "numbits" integer } + { "n" integer } +} +{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ; + +HELP: random-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: random-safe-prime +{ $values + { "numbits" integer } + { "p" integer } +} +{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ; + +HELP: safe-prime? +{ $values + { "q" integer } + { "?" "a boolean" } +} +{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ; + +HELP: unique-primes +{ $values + { "numbits" integer } { "n" integer } + { "seq" sequence } +} +{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ; + +ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test" +"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl +"The Miller-Rabin probabilistic primality test:" +{ $subsection miller-rabin } +{ $subsection miller-rabin* } +"Generating relative prime numbers:" +{ $subsection find-relative-prime } +{ $subsection find-relative-prime* } +"Generating prime numbers:" +{ $subsection next-prime } +{ $subsection random-prime } +"Generating safe prime numbers:" +{ $subsection next-safe-prime } +{ $subsection random-safe-prime } ; + +ABOUT: "math.miller-rabin" diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/miller-rabin/miller-rabin-tests.factor index 676c4bf20d..9981064ec0 100644 --- a/basis/math/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/miller-rabin/miller-rabin-tests.factor @@ -1,4 +1,5 @@ -USING: math.miller-rabin tools.test kernel sequences ; +USING: math.miller-rabin tools.test kernel sequences +math.miller-rabin.private math ; IN: math.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test @@ -6,6 +7,9 @@ IN: math.miller-rabin.tests [ t ] [ 3 miller-rabin ] unit-test [ f ] [ 36 miller-rabin ] unit-test [ t ] [ 37 miller-rabin ] unit-test +[ 2 ] [ 1 next-prime ] unit-test +[ 3 ] [ 2 next-prime ] unit-test +[ 5 ] [ 3 next-prime ] unit-test [ 101 ] [ 100 next-prime ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test [ 100000000000031 ] [ 100000000000000 next-prime ] unit-test @@ -14,6 +18,12 @@ IN: math.miller-rabin.tests [ f ] [ 862 safe-prime? ] unit-test [ t ] [ 7 safe-prime? ] unit-test [ f ] [ 31 safe-prime? ] unit-test +[ t ] [ 47 safe-prime-candidate? ] unit-test +[ t ] [ 47 safe-prime? ] unit-test [ t ] [ 863 safe-prime? ] unit-test [ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test + +[ 47 ] [ 31 next-safe-prime ] unit-test +[ 49 ] [ 50 random-prime log2 ] unit-test +[ 49 ] [ 50 random-bits* log2 ] unit-test diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 5e999aa956..9fd604a003 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -1,15 +1,20 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel locals math math.functions math.ranges -random sequences sets combinators.short-circuit math.bitwise ; +random sequences sets combinators.short-circuit math.bitwise +math math.order ; IN: math.miller-rabin odd ( n -- int ) dup even? [ 1 + ] when ; foldable +: >odd ( n -- int ) 0 set-bit ; foldable : >even ( n -- int ) 0 clear-bit ; foldable +: next-even ( m -- n ) >even 2 + ; + +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; + TUPLE: positive-even-expected n ; :: (miller-rabin) ( n trials -- ? ) @@ -18,7 +23,7 @@ TUPLE: positive-even-expected n ; 0 :> a! trials [ drop - n 1 - [1,b] random a! + 2 n 2 - [a,b] random a! a s n ^mod 1 = [ f ] [ @@ -30,8 +35,6 @@ TUPLE: positive-even-expected n ; PRIVATE> -: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; - : miller-rabin* ( n numtrials -- ? ) over { { [ dup 1 <= ] [ 3drop f ] } @@ -42,11 +45,21 @@ PRIVATE> : miller-rabin ( n -- ? ) 10 miller-rabin* ; +ERROR: prime-range-error n ; + : next-prime ( n -- p ) - next-odd dup miller-rabin [ next-prime ] unless ; + dup 1 < [ prime-range-error ] when + dup 1 = [ + drop 2 + ] [ + next-odd dup miller-rabin [ next-prime ] unless + ] if ; + +: random-bits* ( numbits -- n ) + 1 - [ random-bits ] keep set-bit ; : random-prime ( numbits -- p ) - random-bits next-prime ; + random-bits* next-prime ; ERROR: no-relative-prime n ; @@ -80,10 +93,7 @@ ERROR: too-few-primes ; safe-prime-form ( q -- p ) 2 * 1 + ; - : safe-prime-candidate? ( n -- ? ) - >safe-prime-form 1 + 6 divisor? ; : next-safe-prime-candidate ( n -- candidate ) @@ -99,14 +109,8 @@ PRIVATE> } 1&& ; : next-safe-prime ( n -- q ) - 1 - >even 2 / next-safe-prime-candidate - dup >safe-prime-form - dup miller-rabin - [ nip ] [ drop next-safe-prime ] if ; - -: random-bits* ( numbits -- n ) - [ random-bits ] keep set-bit ; + dup safe-prime? [ next-safe-prime ] unless ; : random-safe-prime ( numbits -- p ) - 1- random-bits* next-safe-prime ; + random-bits* next-safe-prime ; From fbb17ea7afcd7187297528846be0eae1c20d465d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 6 May 2009 17:26:21 -0500 Subject: [PATCH 16/89] uniform-random-float speed --- basis/random/random.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/basis/random/random.factor b/basis/random/random.factor index e3f1ecccb9..6b02c8a3e8 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -3,7 +3,7 @@ USING: alien.c-types kernel math namespaces sequences io.backend io.binary combinators system vocabs.loader summary math.bitwise byte-vectors fry byte-arrays -math.ranges math.constants math.functions ; +math.ranges math.constants math.functions accessors ; IN: random SYMBOL: system-random-generator @@ -70,8 +70,11 @@ PRIVATE> secure-random-generator get swap with-random ; inline : uniform-random-float ( min max -- n ) - 64 random-bits >float [ over - 2.0 -64 ^ * ] dip - * + ; + 4 random-bytes underlying>> *uint >float + 4 random-bytes underlying>> *uint >float + 2.0 32 ^ * + + [ over - 2.0 -64 ^ * ] dip + * + ; inline : normal-random-float ( mean sigma -- n ) 0.0 1.0 uniform-random-float From c9b97f3f9205c5c0066382a222afd66b0c772b36 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 19:33:58 -0400 Subject: [PATCH 17/89] Add tests for combinations --- .../combinatorics/combinatorics-tests.factor | 51 ++++++++++++++----- 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 5ef435a4e0..8cd02399bc 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -1,18 +1,6 @@ USING: math.combinatorics math.combinatorics.private tools.test ; IN: math.combinatorics.tests -[ { } ] [ 0 factoradic ] unit-test -[ { 1 0 } ] [ 1 factoradic ] unit-test -[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test - -[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test -[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test - -[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test -[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test - [ 1 ] [ 0 factorial ] unit-test [ 1 ] [ 1 factorial ] unit-test [ 3628800 ] [ 10 factorial ] unit-test @@ -31,6 +19,19 @@ IN: math.combinatorics.tests [ 2598960 ] [ 52 5 nCk ] unit-test [ 2598960 ] [ 52 47 nCk ] unit-test + +[ { } ] [ 0 factoradic ] unit-test +[ { 1 0 } ] [ 1 factoradic ] unit-test +[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test + +[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test +[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test + +[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test +[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test + [ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test @@ -43,3 +44,29 @@ IN: math.combinatorics.tests [ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test [ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test + +[ 2598960 ] [ 52 5 choose ] unit-test + +[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test +[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test +[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test +[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test + +[ 9 ] [ 0 5 3 dual-index ] unit-test +[ 0 ] [ 9 5 3 dual-index ] unit-test +[ 179 ] [ 72 10 5 dual-index ] unit-test + +[ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test +[ { 4 3 2 1 0 } ] [ 10 5 0 combinadic ] unit-test +[ { 8 6 3 1 0 } ] [ 10 5 72 combinadic ] unit-test +[ { 9 8 7 6 5 } ] [ 10 5 251 combinadic ] unit-test + +[ { 0 1 2 } ] [ 0 5 3 combination-indices ] unit-test +[ { 2 3 4 } ] [ 9 5 3 combination-indices ] unit-test + +[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test +[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test + +[ { { "a" "b" } { "a" "c" } + { "a" "d" } { "b" "c" } + { "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test From 678f603aa5495f92285303f375635410b20c00cc Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 20:18:21 -0400 Subject: [PATCH 18/89] Clean up combinations a bit --- basis/math/combinatorics/combinatorics.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index dd71ded8c2..b2e21e429a 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -46,7 +46,8 @@ PRIVATE> [ permutation-indices ] keep nths ; : all-permutations ( seq -- seq ) - [ length factorial ] keep '[ _ permutation ] map ; + [ length factorial ] keep + '[ _ permutation ] map ; : each-permutation ( seq quot -- ) [ [ length factorial ] keep ] dip @@ -69,6 +70,9 @@ TUPLE: combo C: combo +: choose ( combo -- nCk ) + [ seq>> length ] [ k>> ] bi nCk ; + : largest-value ( a b x -- v ) #! TODO: use a binary search instead of find-last [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ; @@ -79,26 +83,23 @@ C: combo x v b nCk - ! x' v ; ! v == a' -: dual-index ( combo m -- x ) - [ [ seq>> length ] [ k>> ] bi nCk 1 - ] dip - ; +: dual-index ( m combo -- m' ) + choose 1 - swap - ; -: initial-values ( combo m -- a b x ) - [ [ seq>> length ] [ k>> ] [ ] tri ] dip dual-index ; +: initial-values ( combo m -- n k m ) + [ [ seq>> length ] [ k>> ] bi ] dip ; : combinadic ( combo m -- combinadic ) initial-values [ over 0 > ] [ next-values ] produce [ 3drop ] dip ; : combination-indices ( m combo -- seq ) - [ swap combinadic ] keep + [ tuck dual-index combinadic ] keep seq>> length 1 - swap [ - ] with map ; : apply-combination ( m combo -- seq ) [ combination-indices ] keep seq>> nths ; -: choose ( combo -- nCk ) - [ seq>> length ] [ k>> ] bi nCk ; - PRIVATE> : combination ( m seq k -- seq ) From 581d017b46a8a1884417a3470eac0b17341e5c98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 19:22:22 -0500 Subject: [PATCH 19/89] Working on inline caching for tail call sites --- basis/bootstrap/image/image.factor | 45 ++++++++++-------- basis/compiler/codegen/fixup/fixup.factor | 3 ++ basis/compiler/constants/constants.factor | 24 +++++----- basis/cpu/ppc/ppc.factor | 6 ++- basis/cpu/x86/32/32.factor | 2 + basis/cpu/x86/64/64.factor | 2 + basis/cpu/x86/bootstrap.factor | 2 + basis/cpu/x86/x86.factor | 9 +++- core/bootstrap/primitives.factor | 4 +- core/generic/hook/hook.factor | 2 - core/generic/single/single-tests.factor | 2 +- core/generic/single/single.factor | 8 +++- core/generic/standard/standard.factor | 13 ++++-- core/words/words.factor | 3 +- vm/code_block.cpp | 57 +++++++++++++++++------ vm/code_block.hpp | 8 ++-- vm/code_heap.cpp | 4 +- vm/cpu-x86.32.S | 5 +- vm/cpu-x86.64.S | 4 +- vm/cpu-x86.hpp | 21 ++++++--- vm/inline_cache.cpp | 35 ++++++++++---- vm/inline_cache.hpp | 3 +- vm/layouts.hpp | 4 +- vm/primitives.cpp | 1 + vm/run.hpp | 5 +- vm/words.cpp | 3 +- 26 files changed, 187 insertions(+), 88 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index cad40b6384..675c50732d 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -168,6 +168,7 @@ SYMBOL: pic-check-tag SYMBOL: pic-check SYMBOL: pic-hit SYMBOL: pic-miss-word +SYMBOL: pic-miss-tail-word ! Megamorphic dispatch SYMBOL: mega-lookup @@ -193,25 +194,26 @@ SYMBOL: undefined-quot { jit-return 34 } { jit-profiling 35 } { jit-push-immediate 36 } - { jit-save-stack 38 } - { jit-dip-word 39 } - { jit-dip 40 } - { jit-2dip-word 41 } - { jit-2dip 42 } - { jit-3dip-word 43 } - { jit-3dip 44 } - { jit-execute-word 45 } - { jit-execute-jump 46 } - { jit-execute-call 47 } - { pic-load 48 } - { pic-tag 49 } - { pic-hi-tag 50 } - { pic-tuple 51 } - { pic-hi-tag-tuple 52 } - { pic-check-tag 53 } - { pic-check 54 } - { pic-hit 55 } - { pic-miss-word 56 } + { jit-save-stack 37 } + { jit-dip-word 38 } + { jit-dip 39 } + { jit-2dip-word 40 } + { jit-2dip 41 } + { jit-3dip-word 42 } + { jit-3dip 43 } + { jit-execute-word 44 } + { jit-execute-jump 45 } + { jit-execute-call 46 } + { pic-load 47 } + { pic-tag 48 } + { pic-hi-tag 49 } + { pic-tuple 50 } + { pic-hi-tag-tuple 51 } + { pic-check-tag 52 } + { pic-check 53 } + { pic-hit 54 } + { pic-miss-word 55 } + { pic-miss-tail-word 56 } { mega-lookup 57 } { mega-lookup-word 58 } { mega-miss-word 59 } @@ -351,7 +353,8 @@ M: f ' [ vocabulary>> , ] [ def>> , ] [ props>> , ] - [ direct-entry-def>> , ] ! direct-entry-def + [ pic-def>> , ] + [ pic-tail-def>> , ] [ drop 0 , ] ! count [ word-sub-primitive , ] [ drop 0 , ] ! xt @@ -524,6 +527,7 @@ M: quotation ' \ 3dip jit-3dip-word set \ (execute) jit-execute-word set \ inline-cache-miss \ pic-miss-word set + \ inline-cache-miss-tail \ pic-miss-tail-word set \ mega-cache-lookup \ mega-lookup-word set \ mega-cache-miss \ mega-miss-word set [ undefined ] undefined-quot set @@ -559,6 +563,7 @@ M: quotation ' pic-check pic-hit pic-miss-word + pic-miss-tail-word mega-lookup mega-lookup-word mega-miss-word diff --git a/basis/compiler/codegen/fixup/fixup.factor b/basis/compiler/codegen/fixup/fixup.factor index b52bb51b26..d0c874feb0 100755 --- a/basis/compiler/codegen/fixup/fixup.factor +++ b/basis/compiler/codegen/fixup/fixup.factor @@ -59,6 +59,9 @@ SYMBOL: literal-table : rel-word-pic ( word class -- ) [ add-literal ] dip rt-xt-pic rel-fixup ; +: rel-word-pic-tail ( word class -- ) + [ add-literal ] dip rt-xt-pic-tail rel-fixup ; + : rel-primitive ( word class -- ) [ def>> first add-literal ] dip rt-primitive rel-fixup ; diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 886933b5cd..5e0ee98606 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel layouts system strings words quotations byte-arrays -alien arrays ; +alien arrays literals sequences ; IN: compiler.constants ! These constants must match vm/memory.h @@ -14,14 +14,14 @@ CONSTANT: deck-bits 18 : float-offset ( -- n ) 8 float tag-number - ; inline : string-offset ( -- n ) 4 bootstrap-cells string tag-number - ; inline : string-aux-offset ( -- n ) 2 bootstrap-cells string tag-number - ; inline -: profile-count-offset ( -- n ) 7 bootstrap-cells \ word tag-number - ; inline +: profile-count-offset ( -- n ) 8 bootstrap-cells \ word tag-number - ; inline : byte-array-offset ( -- n ) 2 bootstrap-cells byte-array tag-number - ; inline : alien-offset ( -- n ) 3 bootstrap-cells alien tag-number - ; inline : underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline : tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline -: word-xt-offset ( -- n ) 9 bootstrap-cells \ word tag-number - ; inline +: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline : quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline -: word-code-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline +: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline : array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline @@ -43,14 +43,12 @@ CONSTANT: rt-dlsym 1 CONSTANT: rt-dispatch 2 CONSTANT: rt-xt 3 CONSTANT: rt-xt-pic 4 -CONSTANT: rt-here 5 -CONSTANT: rt-this 6 -CONSTANT: rt-immediate 7 -CONSTANT: rt-stack-chain 8 -CONSTANT: rt-untagged 9 +CONSTANT: rt-xt-pic-tail 5 +CONSTANT: rt-here 6 +CONSTANT: rt-this 7 +CONSTANT: rt-immediate 8 +CONSTANT: rt-stack-chain 9 +CONSTANT: rt-untagged 10 : rc-absolute? ( n -- ? ) - [ rc-absolute-ppc-2/2 = ] - [ rc-absolute-cell = ] - [ rc-absolute = ] - tri or or ; + ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index c239bacbc0..a11b0daa86 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -114,7 +114,11 @@ M: ppc stack-frame-size ( stack-frame -- i ) 4 cells align ; M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; -M: ppc %jump ( word -- ) 0 B rc-relative-ppc-3 rel-word ; + +M: ppc %jump ( word -- ) + 0 3 LOAD32 rc-absolute-ppc-2/2 rel-here + 0 B rc-relative-ppc-3 rel-word-pic-tail ; + M: ppc %jump-label ( label -- ) B ; M: ppc %return ( -- ) BLR ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 376edeb202..0a0ac4a53e 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -42,6 +42,8 @@ M:: x86.32 %dispatch ( src temp offset -- ) M: x86.32 param-reg-1 EAX ; M: x86.32 param-reg-2 EDX ; +M: x86.32 pic-tail-reg EBX ; + M: x86.32 reserved-area-size 0 ; M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 8cc69958a4..ad1b487e44 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -39,6 +39,8 @@ M: x86.64 param-reg-1 int-regs param-regs first ; M: x86.64 param-reg-2 int-regs param-regs second ; : param-reg-3 ( -- reg ) int-regs param-regs third ; inline +M: x86.64 pic-tail-reg RBX ; + M: int-regs return-reg drop RAX ; M: float-regs return-reg drop XMM0 ; diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 4b409102c9..8d35d4ed8a 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -152,6 +152,8 @@ big-endian off ! ! ! Polymorphic inline caches +! The PIC and megamorphic code stubs are not permitted to touch temp3. + ! Load a value from a stack position [ temp1 ds-reg HEX: ffffffff [+] MOV rc-absolute rt-untagged jit-rel diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index d508d7740b..5ae9e1c489 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -23,6 +23,8 @@ HOOK: temp-reg-2 cpu ( -- reg ) HOOK: param-reg-1 cpu ( -- reg ) HOOK: param-reg-2 cpu ( -- reg ) +HOOK: pic-tail-reg cpu ( -- reg ) + M: x86 %load-immediate MOV ; M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ; @@ -58,8 +60,13 @@ M: x86 stack-frame-size ( stack-frame -- i ) align-stack ; M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; -M: x86 %jump ( word -- ) 0 JMP rc-relative rel-word ; + +M: x86 %jump ( word -- ) + pic-tail-reg 0 MOV 2 cells 1 + rc-absolute-cell rel-here + 0 JMP rc-relative rel-word-pic-tail ; + M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ; + M: x86 %return ( -- ) 0 RET ; : code-alignment ( align -- n ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 83276cd3f2..57bc61a005 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -231,7 +231,8 @@ bi "vocabulary" { "def" { "quotation" "quotations" } initial: [ ] } "props" - { "direct-entry-def" } + "pic-def" + "pic-tail-def" { "counter" { "fixnum" "math" } } { "sub-primitive" read-only } } define-builtin @@ -505,6 +506,7 @@ tuple { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } { "inline-cache-miss" "generic.single.private" (( generic methods index cache -- )) } + { "inline-cache-miss-tail" "generic.single.private" (( generic methods index cache -- )) } { "mega-cache-miss" "generic.single.private" (( methods index cache -- method )) } { "lookup-method" "generic.single.private" (( object methods -- method )) } { "reset-dispatch-stats" "generic.single" (( -- )) } diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor index fe5b62f6c0..5edbc54bd8 100644 --- a/core/generic/hook/hook.factor +++ b/core/generic/hook/hook.factor @@ -17,8 +17,6 @@ M: hook-combination picker M: hook-combination dispatch# drop 0 ; -M: hook-combination inline-cache-quot 2drop f ; - M: hook-combination mega-cache-quot 1quotation picker [ lookup-method (execute) ] surround ; diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor index c8cab970fd..e48d404b92 100644 --- a/core/generic/single/single-tests.factor +++ b/core/generic/single/single-tests.factor @@ -273,5 +273,5 @@ M: growable call-next-hooker call-next-method "growable " prepend ; [ ] [ "IN: generic.single.tests GENERIC: xyz ( a -- b )" eval( -- ) ] unit-test [ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test -[ f ] [ "xyz" "generic.single.tests" lookup direct-entry-def>> ] unit-test +[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test [ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test \ No newline at end of file diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index d8fa04edd6..36a76153f9 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -238,10 +238,14 @@ M: f compile-engine ; [ compile-engine ] bi ] tri ; -HOOK: inline-cache-quot combination ( word methods -- quot/f ) +HOOK: inline-cache-quots combination ( word methods -- pic-quot/f pic-tail-quot/f ) + +M: single-combination inline-cache-quots 2drop f f ; : define-inline-cache-quot ( word methods -- ) - [ drop ] [ inline-cache-quot ] 2bi >>direct-entry-def drop ; + [ drop ] [ inline-cache-quots ] 2bi + [ >>pic-def ] [ >>pic-tail-def ] bi* + drop ; HOOK: mega-cache-quot combination ( methods -- quot/f ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index bf801c4e47..b76bcaa582 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -3,7 +3,7 @@ USING: accessors definitions generic generic.single kernel namespaces words math math.order combinators sequences generic.single.private quotations kernel.private -assocs arrays layouts ; +assocs arrays layouts make ; IN: generic.standard TUPLE: standard-combination < single-combination # ; @@ -38,17 +38,22 @@ M: standard-generic effective-method [ datastack ] dip [ "combination" word-prop #>> swap nth ] keep (effective-method) ; -M: standard-combination inline-cache-quot ( word methods -- ) +: inline-cache-quot ( word methods miss-word -- quot ) + [ [ literalize , ] [ , ] [ combination get #>> , { } , , ] tri* ] [ ] make ; + +M: standard-combination inline-cache-quots #! Direct calls to the generic word (not tail calls or indirect calls) #! will jump to the inline cache entry point instead of the megamorphic #! dispatch entry point. - combination get #>> [ { } inline-cache-miss ] 3curry [ ] like ; + [ \ inline-cache-miss inline-cache-quot ] + [ \ inline-cache-miss-tail inline-cache-quot ] + 2bi ; : make-empty-cache ( -- array ) mega-cache-size get f ; M: standard-combination mega-cache-quot - combination get #>> make-empty-cache [ mega-cache-lookup ] 3curry [ ] like ; + combination get #>> make-empty-cache \ mega-cache-lookup [ ] 4sequence ; M: standard-generic definer drop \ GENERIC# f ; diff --git a/core/words/words.factor b/core/words/words.factor index 1976c1e4cd..c01cf13bcd 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -155,7 +155,8 @@ M: word reset-word [ subwords forget-all ] [ reset-word ] [ - f >>direct-entry-def + f >>pic-def + f >>pic-tail-def { "methods" "combination" diff --git a/vm/code_block.cpp b/vm/code_block.cpp index cd87da3801..1da16ad0a1 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -27,7 +27,8 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter) { case RT_PRIMITIVE: case RT_XT: - case RT_XT_DIRECT: + case RT_XT_PIC: + case RT_XT_PIC_TAIL: case RT_IMMEDIATE: case RT_HERE: case RT_UNTAGGED: @@ -171,9 +172,8 @@ void *object_xt(cell obj) } } -void *word_direct_xt(word *w) +static void *xt_pic(word *w, cell tagged_quot) { - cell tagged_quot = w->direct_entry_def; if(tagged_quot == F || max_pic_size == 0) return w->xt; else @@ -186,20 +186,42 @@ void *word_direct_xt(word *w) } } +void *word_xt_pic(word *w) +{ + return xt_pic(w,w->pic_def); +} + +void *word_xt_pic_tail(word *w) +{ + return xt_pic(w,w->pic_tail_def); +} + void update_word_references_step(relocation_entry rel, cell index, code_block *compiled) { relocation_type type = REL_TYPE(rel); - if(type == RT_XT || type == RT_XT_DIRECT) + if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL) { cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); array *literals = untag(compiled->literals); cell obj = array_nth(literals,index); void *xt; - if(type == RT_XT) + switch(type) + { + case RT_XT: xt = object_xt(obj); - else - xt = word_direct_xt(untag(obj)); + break; + case RT_XT_PIC: + xt = word_xt_pic(untag(obj)); + break; + case RT_XT_PIC_TAIL: + xt = word_xt_pic_tail(untag(obj)); + break; + default: + critical_error("Oops",type); + xt = NULL; + break; + } store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt); } @@ -367,25 +389,30 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp array *literals = untag(compiled->literals); fixnum absolute_value; +#define ARG array_nth(literals,index) + switch(REL_TYPE(rel)) { case RT_PRIMITIVE: - absolute_value = (cell)primitives[untag_fixnum(array_nth(literals,index))]; + absolute_value = (cell)primitives[untag_fixnum(ARG)]; break; case RT_DLSYM: absolute_value = (cell)get_rel_symbol(literals,index); break; case RT_IMMEDIATE: - absolute_value = array_nth(literals,index); + absolute_value = ARG; break; case RT_XT: - absolute_value = (cell)object_xt(array_nth(literals,index)); + absolute_value = (cell)object_xt(ARG); break; - case RT_XT_DIRECT: - absolute_value = (cell)word_direct_xt(untag(array_nth(literals,index))); + case RT_XT_PIC: + absolute_value = (cell)word_xt_pic(untag(ARG)); + break; + case RT_XT_PIC_TAIL: + absolute_value = (cell)word_xt_pic_tail(untag(ARG)); break; case RT_HERE: - absolute_value = offset + (short)untag_fixnum(array_nth(literals,index)); + absolute_value = offset + (short)untag_fixnum(ARG); break; case RT_THIS: absolute_value = (cell)(compiled + 1); @@ -394,13 +421,15 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp absolute_value = (cell)&stack_chain; break; case RT_UNTAGGED: - absolute_value = untag_fixnum(array_nth(literals,index)); + absolute_value = untag_fixnum(ARG); break; default: critical_error("Bad rel type",rel); return; /* Can't happen */ } +#undef ARG + store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); } diff --git a/vm/code_block.hpp b/vm/code_block.hpp index 85ae373845..b30de9d148 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -8,10 +8,12 @@ enum relocation_type { RT_DLSYM, /* a pointer to a compiled word reference */ RT_DISPATCH, - /* a word's general entry point XT */ + /* a word or quotation's general entry point */ RT_XT, - /* a word's direct entry point XT */ - RT_XT_DIRECT, + /* a word's PIC entry point */ + RT_XT_PIC, + /* a word's tail-call PIC entry point */ + RT_XT_PIC_TAIL, /* current offset */ RT_HERE, /* current code block */ diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 77c78ad533..c8c7639930 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -26,8 +26,8 @@ void jit_compile_word(cell word_, cell def_, bool relocate) word->code = def->code; - if(word->direct_entry_def != F) - jit_compile(word->direct_entry_def,relocate); + if(word->pic_def != F) jit_compile(word->pic_def,relocate); + if(word->pic_tail_def != F) jit_compile(word->pic_tail_def,relocate); } /* Apply a function to every code block */ diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 0c08ea7b46..a1ce83932e 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -60,9 +60,10 @@ DEF(bool,check_sse2,(void)): ret DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): - mov (%esp),%eax + mov (%esp),%ebx +DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)): sub $8,%esp - push %eax + push %ebx call MANGLE(inline_cache_miss) add $12,%esp jmp *%eax diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 5a70280ddf..0ace354308 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -73,8 +73,10 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi ret /* return _with new stack_ */ DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): - mov (%rsp),ARG0 + mov (%rsp),%rbx +DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)): sub $STACK_PADDING,%rsp + mov %rbx,ARG0 call MANGLE(inline_cache_miss) add $STACK_PADDING,%rsp jmp *%rax diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index c0b4651811..9b6f2ed577 100755 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -7,15 +7,19 @@ namespace factor inline static void flush_icache(cell start, cell len) {} +static const unsigned char call_opcode = 0xe8; +static const unsigned char jmp_opcode = 0xe9; + +inline static unsigned char call_site_opcode(cell return_address) +{ + return *(unsigned char *)(return_address - 5); +} + inline static void check_call_site(cell return_address) { - /* An x86 CALL instruction looks like so: - |e8|..|..|..|..| - where the ... are a PC-relative jump address. - The return_address points to right after the - instruction. */ #ifdef FACTOR_DEBUG - assert(*(unsigned char *)(return_address - 5) == 0xe8); + unsigned char opcode = call_site_opcode(return_address); + assert(opcode == call_opcode || opcode == jmp_opcode); #endif } @@ -31,6 +35,11 @@ inline static void set_call_target(cell return_address, void *target) *(int *)(return_address - 4) = ((cell)target - return_address); } +inline static bool tail_call_site_p(cell return_address) +{ + return call_site_opcode(return_address) == jmp_opcode; +} + /* Defined in assembly */ VM_ASM_API void c_to_factor(cell quot); VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to); diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index 59632c4185..34d03e24f0 100755 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -86,7 +86,11 @@ struct inline_cache_jit : public jit { inline_cache_jit(cell generic_word_) : jit(PIC_TYPE,generic_word_) {}; void emit_check(cell klass); - void compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_); + void compile_inline_cache(fixnum index, + cell generic_word_, + cell methods_, + cell cache_entries_, + bool tail_call_p); }; void inline_cache_jit::emit_check(cell klass) @@ -102,7 +106,11 @@ void inline_cache_jit::emit_check(cell klass) /* index: 0 = top of stack, 1 = item underneath, etc cache_entries: array of class/method pairs */ -void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, cell methods_, cell cache_entries_) +void inline_cache_jit::compile_inline_cache(fixnum index, + cell generic_word_, + cell methods_, + cell cache_entries_, + bool tail_call_p) { gc_root generic_word(generic_word_); gc_root methods(methods_); @@ -136,20 +144,25 @@ void inline_cache_jit::compile_inline_cache(fixnum index, cell generic_word_, ce push(methods.value()); push(tag_fixnum(index)); push(cache_entries.value()); - word_jump(userenv[PIC_MISS_WORD]); + word_jump(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]); } static code_block *compile_inline_cache(fixnum index, - cell generic_word_, - cell methods_, - cell cache_entries_) + cell generic_word_, + cell methods_, + cell cache_entries_, + bool tail_call_p) { gc_root generic_word(generic_word_); gc_root methods(methods_); gc_root cache_entries(cache_entries_); inline_cache_jit jit(generic_word.value()); - jit.compile_inline_cache(index,generic_word.value(),methods.value(),cache_entries.value()); + jit.compile_inline_cache(index, + generic_word.value(), + methods.value(), + cache_entries.value(), + tail_call_p); code_block *code = jit.to_code_block(); relocate_code_block(code); return code; @@ -227,14 +240,18 @@ void *inline_cache_miss(cell return_address) xt = compile_inline_cache(index, generic_word.value(), methods.value(), - new_cache_entries.value()) + 1; + new_cache_entries.value(), + tail_call_site_p(return_address))->xt(); } /* Install the new stub. */ set_call_target(return_address,xt); #ifdef PIC_DEBUG - printf("Updated call site 0x%lx with 0x%lx\n",return_address,(cell)xt); + printf("Updated %s call site 0x%lx with 0x%lx\n", + tail_call_site_p(return_address) ? "tail" : "non-tail", + return_address, + (cell)xt); #endif return xt; diff --git a/vm/inline_cache.hpp b/vm/inline_cache.hpp index 84334efc78..e2a6ae8cf9 100644 --- a/vm/inline_cache.hpp +++ b/vm/inline_cache.hpp @@ -8,7 +8,8 @@ void init_inline_caching(int max_size); PRIMITIVE(reset_inline_cache_stats); PRIMITIVE(inline_cache_stats); PRIMITIVE(inline_cache_miss); +PRIMITIVE(inline_cache_miss_tail); -extern "C" void *inline_cache_miss(cell return_address); +VM_C_API void *inline_cache_miss(cell return_address); } diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 8c96cf3187..f8d114210a 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -229,7 +229,9 @@ struct word : public object { /* TAGGED property assoc for library code */ cell props; /* TAGGED alternative entry point for direct non-tail calls. Used for inline caching */ - cell direct_entry_def; + cell pic_def; + /* TAGGED alternative entry point for direct tail calls. Used for inline caching */ + cell pic_tail_def; /* TAGGED call count for profiling */ cell counter; /* TAGGED machine code for sub-primitive */ diff --git a/vm/primitives.cpp b/vm/primitives.cpp index f1c5468949..bd761625d8 100755 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -147,6 +147,7 @@ const primitive_type primitives[] = { primitive_load_locals, primitive_check_datastack, primitive_inline_cache_miss, + primitive_inline_cache_miss_tail, primitive_mega_cache_miss, primitive_lookup_method, primitive_reset_dispatch_stats, diff --git a/vm/run.hpp b/vm/run.hpp index 829e25d2f7..48ebb8cf41 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -48,7 +48,7 @@ enum special_object { JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_SAVE_STACK = 38, + JIT_SAVE_STACK, JIT_DIP_WORD, JIT_DIP, JIT_2DIP_WORD, @@ -60,7 +60,7 @@ enum special_object { JIT_EXECUTE_CALL, /* Polymorphic inline cache generation in inline_cache.c */ - PIC_LOAD = 48, + PIC_LOAD = 47, PIC_TAG, PIC_HI_TAG, PIC_TUPLE, @@ -69,6 +69,7 @@ enum special_object { PIC_CHECK, PIC_HIT, PIC_MISS_WORD, + PIC_MISS_TAIL_WORD, /* Megamorphic cache generation in dispatch.c */ MEGA_LOOKUP = 57, diff --git a/vm/words.cpp b/vm/words.cpp index 6e7c633c84..fa090c9cea 100644 --- a/vm/words.cpp +++ b/vm/words.cpp @@ -16,7 +16,8 @@ word *allot_word(cell vocab_, cell name_) new_word->def = userenv[UNDEFINED_ENV]; new_word->props = F; new_word->counter = tag_fixnum(0); - new_word->direct_entry_def = F; + new_word->pic_def = F; + new_word->pic_tail_def = F; new_word->subprimitive = F; new_word->profiling = NULL; new_word->code = NULL; From 78037d8d0558d01abdc0609bddf23b53fe7cc6c0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 20:46:41 -0400 Subject: [PATCH 20/89] Use binary-search instead of find-last for combinations --- basis/math/combinatorics/combinatorics.factor | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index b2e21e429a..5bda23f738 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs fry kernel locals math math.order math.ranges mirrors - namespaces sequences sorting ; +USING: accessors assocs binary-search fry kernel locals math math.order + math.ranges mirrors namespaces sequences sorting ; IN: math.combinatorics combo [ seq>> length ] [ k>> ] bi nCk ; : largest-value ( a b x -- v ) - #! TODO: use a binary search instead of find-last - [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ; + dup 0 = [ + drop 1 - nip + ] [ + [ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip + ] if ; :: next-values ( a b x -- a' b' x' v ) a b x largest-value dup :> v ! a' From 12a34d81f7ddcab3ef2df9edec41166ed69c8657 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 20:04:49 -0500 Subject: [PATCH 21/89] JIT now supports multiple relocations per code template. This simplifies non-optimizing compiler backends --- basis/bootstrap/image/image.factor | 31 ++++++++++-------------------- basis/cpu/ppc/bootstrap.factor | 8 +------- basis/cpu/x86/32/bootstrap.factor | 6 ++---- basis/cpu/x86/64/bootstrap.factor | 5 +---- basis/cpu/x86/bootstrap.factor | 5 +---- vm/jit.cpp | 29 ++++++++++++---------------- vm/jit.hpp | 4 ++-- vm/quotations.cpp | 6 +++--- vm/run.hpp | 6 ++---- 9 files changed, 34 insertions(+), 66 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 675c50732d..7b39cee101 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -93,24 +93,19 @@ CONSTANT: -1-offset 9 SYMBOL: sub-primitives -SYMBOL: jit-define-rc -SYMBOL: jit-define-rt -SYMBOL: jit-define-offset +SYMBOL: jit-relocations -: compute-offset ( -- offset ) - building get length jit-define-rc get rc-absolute-cell = bootstrap-cell 4 ? - ; +: compute-offset ( rc -- offset ) + [ building get length ] dip rc-absolute-cell = bootstrap-cell 4 ? - ; : jit-rel ( rc rt -- ) - jit-define-rt set - jit-define-rc set - compute-offset jit-define-offset set ; + over compute-offset 3array jit-relocations get push-all ; -: make-jit ( quot -- quad ) +: make-jit ( quot -- jit-data ) [ + V{ } clone jit-relocations set call( -- ) - jit-define-rc get - jit-define-rt get - jit-define-offset get 3array + jit-relocations get >array ] B{ } make prefix ; : jit-define ( quot name -- ) @@ -142,8 +137,7 @@ SYMBOL: jit-word-jump SYMBOL: jit-word-call SYMBOL: jit-push-immediate SYMBOL: jit-if-word -SYMBOL: jit-if-1 -SYMBOL: jit-if-2 +SYMBOL: jit-if SYMBOL: jit-dip-word SYMBOL: jit-dip SYMBOL: jit-2dip-word @@ -156,7 +150,6 @@ SYMBOL: jit-execute-call SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling -SYMBOL: jit-save-stack ! PIC stubs SYMBOL: pic-load @@ -188,13 +181,11 @@ SYMBOL: undefined-quot { jit-word-jump 26 } { jit-word-call 27 } { jit-if-word 28 } - { jit-if-1 29 } - { jit-if-2 30 } + { jit-if 29 } { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } { jit-push-immediate 36 } - { jit-save-stack 37 } { jit-dip-word 38 } { jit-dip 39 } { jit-2dip-word 40 } @@ -539,8 +530,7 @@ M: quotation ' jit-word-call jit-push-immediate jit-if-word - jit-if-1 - jit-if-2 + jit-if jit-dip-word jit-dip jit-2dip-word @@ -553,7 +543,6 @@ M: quotation ' jit-epilog jit-return jit-profiling - jit-save-stack pic-load pic-tag pic-hi-tag diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 8001868e0c..768b919d4f 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -50,9 +50,6 @@ CONSTANT: rs-reg 14 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel 7 6 0 LWZ 1 7 0 STW -] jit-save-stack jit-define - -[ 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel 6 MTCTR BCTR @@ -68,11 +65,8 @@ CONSTANT: rs-reg 14 0 3 \ f tag-number CMPI 2 BEQ 0 B rc-relative-ppc-3 rt-xt jit-rel -] jit-if-1 jit-define - -[ 0 B rc-relative-ppc-3 rt-xt jit-rel -] jit-if-2 jit-define +] jit-if jit-define : jit->r ( -- ) 4 ds-reg 0 LWZ diff --git a/basis/cpu/x86/32/bootstrap.factor b/basis/cpu/x86/32/bootstrap.factor index 660a428dfb..490d37ccbc 100644 --- a/basis/cpu/x86/32/bootstrap.factor +++ b/basis/cpu/x86/32/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler layouts vocabs parser compiler.constants ; @@ -26,9 +26,7 @@ IN: bootstrap.x86 temp0 0 [] MOV rc-absolute-cell rt-stack-chain jit-rel ! save stack pointer temp0 [] stack-reg MOV -] jit-save-stack jit-define - -[ + ! call the primitive 0 JMP rc-relative rt-primitive jit-rel ] jit-primitive jit-define diff --git a/basis/cpu/x86/64/bootstrap.factor b/basis/cpu/x86/64/bootstrap.factor index 8d1ed086e7..c5c7e63dbc 100644 --- a/basis/cpu/x86/64/bootstrap.factor +++ b/basis/cpu/x86/64/bootstrap.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: bootstrap.image.private kernel namespaces system cpu.x86.assembler layouts vocabs parser compiler.constants math ; @@ -25,9 +25,6 @@ IN: bootstrap.x86 temp0 temp0 [] MOV ! save stack pointer temp0 [] stack-reg MOV -] jit-save-stack jit-define - -[ ! load XT temp1 0 MOV rc-absolute-cell rt-primitive jit-rel ! go diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 8d35d4ed8a..ee75281a9d 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -58,12 +58,9 @@ big-endian off temp0 \ f tag-number CMP ! jump to true branch if not equal 0 JNE rc-relative rt-xt jit-rel -] jit-if-1 jit-define - -[ ! jump to false branch if equal 0 JMP rc-relative rt-xt jit-rel -] jit-if-2 jit-define +] jit-if jit-define : jit->r ( -- ) rs-reg bootstrap-cell ADD diff --git a/vm/jit.cpp b/vm/jit.cpp index bb86506058..a3f222a953 100644 --- a/vm/jit.cpp +++ b/vm/jit.cpp @@ -23,24 +23,21 @@ jit::jit(cell type_, cell owner_) if(stack_traces_p()) literal(owner.value()); } -relocation_entry jit::rel_to_emit(cell code_template, bool *rel_p) +void jit::emit_relocation(cell code_template_) { - array *quadruple = untag(code_template); - cell rel_class = array_nth(quadruple,1); - cell rel_type = array_nth(quadruple,2); - cell offset = array_nth(quadruple,3); + gc_root code_template(code_template_); + cell capacity = array_capacity(code_template.untagged()); + for(cell i = 1; i < capacity; i += 3) + { + cell rel_class = array_nth(code_template.untagged(),i); + cell rel_type = array_nth(code_template.untagged(),i + 1); + cell offset = array_nth(code_template.untagged(),i + 2); - if(rel_class == F) - { - *rel_p = false; - return 0; - } - else - { - *rel_p = true; - return (untag_fixnum(rel_type) << 28) + relocation_entry new_entry + = (untag_fixnum(rel_type) << 28) | (untag_fixnum(rel_class) << 24) | ((code.count + untag_fixnum(offset))); + relocation.append_bytes(&new_entry,sizeof(relocation_entry)); } } @@ -49,9 +46,7 @@ void jit::emit(cell code_template_) { gc_root code_template(code_template_); - bool rel_p; - relocation_entry rel = rel_to_emit(code_template.value(),&rel_p); - if(rel_p) relocation.append_bytes(&rel,sizeof(relocation_entry)); + emit_relocation(code_template.value()); gc_root insns(array_nth(code_template.untagged(),0)); diff --git a/vm/jit.hpp b/vm/jit.hpp index 30b5163b4a..976be9ef3b 100644 --- a/vm/jit.hpp +++ b/vm/jit.hpp @@ -14,7 +14,7 @@ struct jit { jit(cell jit_type, cell owner); void compute_position(cell offset); - relocation_entry rel_to_emit(cell code_template, bool *rel_p); + void emit_relocation(cell code_template); void emit(cell code_template); void literal(cell literal) { literals.add(literal); } @@ -35,7 +35,7 @@ struct jit { void emit_subprimitive(cell word_) { gc_root word(word_); gc_root code_template(word->subprimitive); - if(array_nth(code_template.untagged(),1) != F) literal(T); + if(array_capacity(code_template.untagged()) > 1) literal(T); emit(code_template.value()); } diff --git a/vm/quotations.cpp b/vm/quotations.cpp index 555ecc6420..afd9fc3da2 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -165,7 +165,6 @@ void quotation_jit::iterate_quotation() /* Primitive calls */ if(primitive_call_p(i)) { - emit(userenv[JIT_SAVE_STACK]); emit_with(userenv[JIT_PRIMITIVE],obj.value()); i++; @@ -187,8 +186,9 @@ void quotation_jit::iterate_quotation() jit_compile(array_nth(elements.untagged(),i + 1),relocate); } - emit_with(userenv[JIT_IF_1],array_nth(elements.untagged(),i)); - emit_with(userenv[JIT_IF_2],array_nth(elements.untagged(),i + 1)); + literal(array_nth(elements.untagged(),i)); + literal(array_nth(elements.untagged(),i + 1)); + emit(userenv[JIT_IF]); i += 2; diff --git a/vm/run.hpp b/vm/run.hpp index 48ebb8cf41..2072580c79 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -42,14 +42,12 @@ enum special_object { JIT_WORD_JUMP, JIT_WORD_CALL, JIT_IF_WORD, - JIT_IF_1, - JIT_IF_2, + JIT_IF, JIT_EPILOG = 33, JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_SAVE_STACK, - JIT_DIP_WORD, + JIT_DIP_WORD = 38, JIT_DIP, JIT_2DIP_WORD, JIT_2DIP, From b84a3158fa47b9507fd495a75e7cfa63fe72691d Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 21:27:04 -0400 Subject: [PATCH 22/89] Add docs for combination words --- .../combinatorics/combinatorics-docs.factor | 70 +++++++++++++++++-- 1 file changed, 63 insertions(+), 7 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 514c808ee0..7f40969b95 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -1,37 +1,93 @@ -USING: help.markup help.syntax kernel math math.order sequences ; +USING: help.markup help.syntax kernel math math.order multiline sequences ; IN: math.combinatorics HELP: factorial { $values { "n" "a non-negative integer" } { "n!" integer } } { $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "4 factorial ." "24" } +} ; HELP: nPk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } } { $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "10 4 nPk ." "5040" } +} ; HELP: nCk { $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } } { $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "10 4 nCk ." "210" } +} ; HELP: permutation { $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } } { $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." } { $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "1 3 permutation ." "{ 0 2 1 }" } + { $example "USING: math.combinatorics prettyprint ;" + "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } +} ; HELP: all-permutations { $values { "seq" sequence } { "seq" sequence } } { $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } +} ; + +HELP: each-permutation +{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } } +{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ; HELP: inverse-permutation { $values { "seq" sequence } { "permutation" sequence } } { $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." } { $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." } -{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ; +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } + { $example "USING: math.combinatorics prettyprint ;" + "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } +} ; + +HELP: combination +{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } } +{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." } +{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." } +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "6 7 iota 4 combination ." "{ 0 1 3 6 }" } + { $example "USING: math.combinatorics prettyprint ;" + "0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" } +} ; + +HELP: all-combinations +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } } +{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." } +{ $examples + { $example "USING: math.combinatorics prettyprint ;" + "{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ." +<" { + { "a" "b" } + { "a" "c" } + { "a" "d" } + { "b" "c" } + { "b" "d" } + { "c" "d" } +}"> } } ; + +HELP: each-combination +{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } } +{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ; IN: math.combinatorics.private From 83e75166668a614c845e7d215805ca18b2112de6 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 21:31:37 -0400 Subject: [PATCH 23/89] Use iota where necessary in tests --- .../combinatorics/combinatorics-tests.factor | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 8cd02399bc..1bc4bbc825 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -28,9 +28,9 @@ IN: math.combinatorics.tests [ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test [ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test -[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test -[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test -[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test +[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test +[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test +[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test [ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test [ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test @@ -45,24 +45,24 @@ IN: math.combinatorics.tests [ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test -[ 2598960 ] [ 52 5 choose ] unit-test +[ 2598960 ] [ 52 iota 5 choose ] unit-test [ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test [ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test [ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test [ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test -[ 9 ] [ 0 5 3 dual-index ] unit-test -[ 0 ] [ 9 5 3 dual-index ] unit-test -[ 179 ] [ 72 10 5 dual-index ] unit-test +[ 9 ] [ 0 5 iota 3 dual-index ] unit-test +[ 0 ] [ 9 5 iota 3 dual-index ] unit-test +[ 179 ] [ 72 10 iota 5 dual-index ] unit-test [ { 5 3 2 1 } ] [ 7 4 8 combinadic ] unit-test -[ { 4 3 2 1 0 } ] [ 10 5 0 combinadic ] unit-test -[ { 8 6 3 1 0 } ] [ 10 5 72 combinadic ] unit-test -[ { 9 8 7 6 5 } ] [ 10 5 251 combinadic ] unit-test +[ { 4 3 2 1 0 } ] [ 10 iota 5 0 combinadic ] unit-test +[ { 8 6 3 1 0 } ] [ 10 iota 5 72 combinadic ] unit-test +[ { 9 8 7 6 5 } ] [ 10 iota 5 251 combinadic ] unit-test -[ { 0 1 2 } ] [ 0 5 3 combination-indices ] unit-test -[ { 2 3 4 } ] [ 9 5 3 combination-indices ] unit-test +[ { 0 1 2 } ] [ 0 5 iota 3 combination-indices ] unit-test +[ { 2 3 4 } ] [ 9 5 iota 3 combination-indices ] unit-test [ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test [ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test From 5e4e1ee48fe313dc7771b83306ac0b7a53aad376 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 May 2009 21:44:25 -0400 Subject: [PATCH 24/89] Make a deck of cards an actual tuple --- extra/poker/poker.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index 15e9a96d42..b4353dc925 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -194,8 +194,12 @@ M: hand equal? : >value ( hand -- str ) hand-rank VALUE_STR nth ; +TUPLE: deck + { cards sequence } ; + : ( -- deck ) - RANK_STR SUIT_STR 2array [ concat >ckf ] product-map ; + RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ; -ALIAS: shuffle randomize +: shuffle ( deck -- deck ) + [ randomize ] change-cards ; From 4915e1ced768d459b3ac20acc9d65ffaad340bea Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 22:04:01 -0500 Subject: [PATCH 25/89] Clean up bootstrap.image, and implement new calling convention for tail calls; tail call sites now have PICs --- basis/bootstrap/image/image.factor | 172 ++++++--------------- basis/bootstrap/image/syntax/authors.txt | 1 + basis/bootstrap/image/syntax/syntax.factor | 14 ++ basis/cpu/x86/bootstrap.factor | 7 +- vm/cpu-x86.hpp | 2 + vm/inline_cache.cpp | 2 +- vm/jit.hpp | 8 +- vm/quotations.cpp | 11 +- vm/run.hpp | 5 +- 9 files changed, 93 insertions(+), 129 deletions(-) create mode 100644 basis/bootstrap/image/syntax/authors.txt create mode 100644 basis/bootstrap/image/syntax/syntax.factor diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 7b39cee101..55e6a31491 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -9,7 +9,7 @@ classes.builtin classes.tuple classes.tuple.private vocabs vocabs.loader source-files definitions debugger quotations.private sequences.private combinators math.order math.private accessors slots.private generic.single.private compiler.units compiler.constants -fry ; +fry bootstrap.image.syntax ; IN: bootstrap.image : arch ( os cpu -- arch ) @@ -123,96 +123,59 @@ SYMBOL: big-endian ! Bootstrap architecture name SYMBOL: architecture -! Bootstrap global namesapce -SYMBOL: bootstrap-global +RESET ! Boot quotation, set in stage1.factor -SYMBOL: bootstrap-boot-quot +USERENV: bootstrap-boot-quot 20 + +! Bootstrap global namesapce +USERENV: bootstrap-global 21 ! JIT parameters -SYMBOL: jit-prolog -SYMBOL: jit-primitive-word -SYMBOL: jit-primitive -SYMBOL: jit-word-jump -SYMBOL: jit-word-call -SYMBOL: jit-push-immediate -SYMBOL: jit-if-word -SYMBOL: jit-if -SYMBOL: jit-dip-word -SYMBOL: jit-dip -SYMBOL: jit-2dip-word -SYMBOL: jit-2dip -SYMBOL: jit-3dip-word -SYMBOL: jit-3dip -SYMBOL: jit-execute-word -SYMBOL: jit-execute-jump -SYMBOL: jit-execute-call -SYMBOL: jit-epilog -SYMBOL: jit-return -SYMBOL: jit-profiling +USERENV: jit-prolog 23 +USERENV: jit-primitive-word 24 +USERENV: jit-primitive 25 +USERENV: jit-word-jump 26 +USERENV: jit-word-call 27 +USERENV: jit-word-special 28 +USERENV: jit-if-word 29 +USERENV: jit-if 30 +USERENV: jit-epilog 31 +USERENV: jit-return 32 +USERENV: jit-profiling 33 +USERENV: jit-push-immediate 34 +USERENV: jit-dip-word 35 +USERENV: jit-dip 36 +USERENV: jit-2dip-word 37 +USERENV: jit-2dip 38 +USERENV: jit-3dip-word 39 +USERENV: jit-3dip 40 +USERENV: jit-execute-word 41 +USERENV: jit-execute-jump 42 +USERENV: jit-execute-call 43 ! PIC stubs -SYMBOL: pic-load -SYMBOL: pic-tag -SYMBOL: pic-hi-tag -SYMBOL: pic-tuple -SYMBOL: pic-hi-tag-tuple -SYMBOL: pic-check-tag -SYMBOL: pic-check -SYMBOL: pic-hit -SYMBOL: pic-miss-word -SYMBOL: pic-miss-tail-word +USERENV: pic-load 47 +USERENV: pic-tag 48 +USERENV: pic-hi-tag 49 +USERENV: pic-tuple 50 +USERENV: pic-hi-tag-tuple 51 +USERENV: pic-check-tag 52 +USERENV: pic-check 53 +USERENV: pic-hit 54 +USERENV: pic-miss-word 55 +USERENV: pic-miss-tail-word 56 ! Megamorphic dispatch -SYMBOL: mega-lookup -SYMBOL: mega-lookup-word -SYMBOL: mega-miss-word +USERENV: mega-lookup 57 +USERENV: mega-lookup-word 58 +USERENV: mega-miss-word 59 ! Default definition for undefined words -SYMBOL: undefined-quot - -: userenvs ( -- assoc ) - H{ - { bootstrap-boot-quot 20 } - { bootstrap-global 21 } - { jit-prolog 23 } - { jit-primitive-word 24 } - { jit-primitive 25 } - { jit-word-jump 26 } - { jit-word-call 27 } - { jit-if-word 28 } - { jit-if 29 } - { jit-epilog 33 } - { jit-return 34 } - { jit-profiling 35 } - { jit-push-immediate 36 } - { jit-dip-word 38 } - { jit-dip 39 } - { jit-2dip-word 40 } - { jit-2dip 41 } - { jit-3dip-word 42 } - { jit-3dip 43 } - { jit-execute-word 44 } - { jit-execute-jump 45 } - { jit-execute-call 46 } - { pic-load 47 } - { pic-tag 48 } - { pic-hi-tag 49 } - { pic-tuple 50 } - { pic-hi-tag-tuple 51 } - { pic-check-tag 52 } - { pic-check 53 } - { pic-hit 54 } - { pic-miss-word 55 } - { pic-miss-tail-word 56 } - { mega-lookup 57 } - { mega-lookup-word 58 } - { mega-miss-word 59 } - { undefined-quot 60 } - } ; inline +USERENV: undefined-quot 60 : userenv-offset ( symbol -- n ) - userenvs at header-size + ; + userenvs get at header-size + ; : emit ( cell -- ) image get push ; @@ -504,11 +467,7 @@ M: quotation ' class<=-cache class-not-cache classes-intersect-cache class-and-cache class-or-cache next-method-quot-cache } [ H{ } clone ] H{ } map>assoc assoc-union - bootstrap-global set - bootstrap-global emit-userenv ; - -: emit-boot-quot ( -- ) - bootstrap-boot-quot emit-userenv ; + bootstrap-global set ; : emit-jit-data ( -- ) \ if jit-if-word set @@ -521,43 +480,10 @@ M: quotation ' \ inline-cache-miss-tail \ pic-miss-tail-word set \ mega-cache-lookup \ mega-lookup-word set \ mega-cache-miss \ mega-miss-word set - [ undefined ] undefined-quot set - { - jit-prolog - jit-primitive-word - jit-primitive - jit-word-jump - jit-word-call - jit-push-immediate - jit-if-word - jit-if - jit-dip-word - jit-dip - jit-2dip-word - jit-2dip - jit-3dip-word - jit-3dip - jit-execute-word - jit-execute-jump - jit-execute-call - jit-epilog - jit-return - jit-profiling - pic-load - pic-tag - pic-hi-tag - pic-tuple - pic-hi-tag-tuple - pic-check-tag - pic-check - pic-hit - pic-miss-word - pic-miss-tail-word - mega-lookup - mega-lookup-word - mega-miss-word - undefined-quot - } [ emit-userenv ] each ; + [ undefined ] undefined-quot set ; + +: emit-userenvs ( -- ) + userenvs get keys [ emit-userenv ] each ; : fixup-header ( -- ) heap-size data-heap-size-offset fixup ; @@ -574,8 +500,8 @@ M: quotation ' emit-jit-data "Serializing global namespace..." print flush emit-global - "Serializing boot quotation..." print flush - emit-boot-quot + "Serializing user environment..." print flush + emit-userenvs "Performing word fixups..." print flush fixup-words "Performing header fixups..." print flush diff --git a/basis/bootstrap/image/syntax/authors.txt b/basis/bootstrap/image/syntax/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/bootstrap/image/syntax/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/bootstrap/image/syntax/syntax.factor b/basis/bootstrap/image/syntax/syntax.factor new file mode 100644 index 0000000000..29dc09717a --- /dev/null +++ b/basis/bootstrap/image/syntax/syntax.factor @@ -0,0 +1,14 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser kernel namespaces assocs words.symbol ; +IN: bootstrap.image.syntax + +SYMBOL: userenvs + +SYNTAX: RESET H{ } clone userenvs set-global ; + +SYNTAX: USERENV: + CREATE-WORD scan-word + [ swap userenvs get set-at ] + [ drop define-symbol ] + 2bi ; \ No newline at end of file diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index ee75281a9d..06807ce9fb 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -42,13 +42,18 @@ big-endian off ] jit-push-immediate jit-define [ - 0 JMP rc-relative rt-xt jit-rel + temp3 0 MOV rc-absolute-cell rt-here jit-rel + 0 JMP rc-relative rt-xt-pic-tail jit-rel ] jit-word-jump jit-define [ 0 CALL rc-relative rt-xt-pic jit-rel ] jit-word-call jit-define +[ + 0 JMP rc-relative rt-xt jit-rel +] jit-word-special jit-define + [ ! load boolean temp0 ds-reg [] MOV diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index 9b6f2ed577..71a85b4e82 100755 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -7,6 +7,8 @@ namespace factor inline static void flush_icache(cell start, cell len) {} +static const fixnum xt_tail_pic_offset = 2 * sizeof(cell) + 1; + static const unsigned char call_opcode = 0xe8; static const unsigned char jmp_opcode = 0xe9; diff --git a/vm/inline_cache.cpp b/vm/inline_cache.cpp index 34d03e24f0..e9e098de70 100755 --- a/vm/inline_cache.cpp +++ b/vm/inline_cache.cpp @@ -144,7 +144,7 @@ void inline_cache_jit::compile_inline_cache(fixnum index, push(methods.value()); push(tag_fixnum(index)); push(cache_entries.value()); - word_jump(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]); + word_special(userenv[tail_call_p ? PIC_MISS_TAIL_WORD : PIC_MISS_WORD]); } static code_block *compile_inline_cache(fixnum index, diff --git a/vm/jit.hpp b/vm/jit.hpp index 976be9ef3b..50b40eca30 100644 --- a/vm/jit.hpp +++ b/vm/jit.hpp @@ -25,13 +25,19 @@ struct jit { } void word_jump(cell word) { - emit_with(userenv[JIT_WORD_JUMP],word); + literal(tag_fixnum(xt_tail_pic_offset)); + literal(word); + emit(userenv[JIT_WORD_JUMP]); } void word_call(cell word) { emit_with(userenv[JIT_WORD_CALL],word); } + void word_special(cell word) { + emit_with(userenv[JIT_WORD_SPECIAL],word); + } + void emit_subprimitive(cell word_) { gc_root word(word_); gc_root code_template(word->subprimitive); diff --git a/vm/quotations.cpp b/vm/quotations.cpp index afd9fc3da2..32e5e37a79 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -152,7 +152,16 @@ void quotation_jit::iterate_quotation() { if(stack_frame) emit(userenv[JIT_EPILOG]); tail_call = true; - word_jump(obj.value()); + /* Inline cache misses are special-cased */ + if(obj.value() == userenv[PIC_MISS_WORD] + || obj.value() == userenv[PIC_MISS_TAIL_WORD]) + { + word_special(obj.value()); + } + else + { + word_jump(obj.value()); + } } else word_call(obj.value()); diff --git a/vm/run.hpp b/vm/run.hpp index 2072580c79..7527889efb 100755 --- a/vm/run.hpp +++ b/vm/run.hpp @@ -41,13 +41,14 @@ enum special_object { JIT_PRIMITIVE, JIT_WORD_JUMP, JIT_WORD_CALL, + JIT_WORD_SPECIAL, JIT_IF_WORD, JIT_IF, - JIT_EPILOG = 33, + JIT_EPILOG, JIT_RETURN, JIT_PROFILING, JIT_PUSH_IMMEDIATE, - JIT_DIP_WORD = 38, + JIT_DIP_WORD, JIT_DIP, JIT_2DIP_WORD, JIT_2DIP, From 318552ba605e92385b20c52bc483e6611046a7cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 22:44:30 -0500 Subject: [PATCH 26/89] Fix tail call PICs on x86-64 --- basis/cpu/x86/x86.factor | 6 +++++- vm/cpu-x86.hpp | 10 +++++++++- vm/quotations.cpp | 9 ++++++++- 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 5ae9e1c489..e12cec9738 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -61,8 +61,12 @@ M: x86 stack-frame-size ( stack-frame -- i ) M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ; +: xt-tail-pic-offset ( -- n ) + #! See the comment in vm/cpu-x86.hpp + cell 4 + 1 + ; inline + M: x86 %jump ( word -- ) - pic-tail-reg 0 MOV 2 cells 1 + rc-absolute-cell rel-here + pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here 0 JMP rc-relative rel-word-pic-tail ; M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ; diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index 71a85b4e82..e5852f9ad9 100755 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -7,7 +7,15 @@ namespace factor inline static void flush_icache(cell start, cell len) {} -static const fixnum xt_tail_pic_offset = 2 * sizeof(cell) + 1; +/* In the instruction sequence: + + MOV EBX,... + JMP blah + + the offset from the immediate operand to MOV to the instruction after + the jump is a cell for the immediate operand, 4 bytes for the JMP + destination, and one byte for the JMP opcode. */ +static const fixnum xt_tail_pic_offset = sizeof(cell) + 4 + 1; static const unsigned char call_opcode = 0xe8; static const unsigned char jmp_opcode = 0xe9; diff --git a/vm/quotations.cpp b/vm/quotations.cpp index 32e5e37a79..b049f528e4 100755 --- a/vm/quotations.cpp +++ b/vm/quotations.cpp @@ -152,7 +152,14 @@ void quotation_jit::iterate_quotation() { if(stack_frame) emit(userenv[JIT_EPILOG]); tail_call = true; - /* Inline cache misses are special-cased */ + /* Inline cache misses are special-cased. + The calling convention for tail + calls stores the address of the next + instruction in a register. However, + PIC miss stubs themselves tail-call + the inline cache miss primitive, and + we don't want to clobber the saved + address. */ if(obj.value() == userenv[PIC_MISS_WORD] || obj.value() == userenv[PIC_MISS_TAIL_WORD]) { From 51fff497089be54fc8c63c58e96d2162179c50c8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 23:40:27 -0500 Subject: [PATCH 27/89] find-window: don't bomb if a world has no child. Reported by Joe Groff --- basis/ui/ui.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index d07403836a..b73de68e26 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -145,7 +145,9 @@ SYMBOL: ui-thread PRIVATE> : find-window ( quot -- world ) - [ windows get values ] dip '[ gadget-child @ ] find-last nip ; inline + [ windows get values ] dip + '[ dup children>> [ ] [ nip first ] if-empty @ ] + find-last nip ; inline : ui-running? ( -- ? ) \ ui-running get-global ; From 741e97e57eb3b35b0627bf55667bd9f76c54ee71 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 May 2009 23:47:17 -0500 Subject: [PATCH 28/89] tools.trace: fix for call( --- basis/tools/trace/trace-tests.factor | 30 ++++++++++++++++++++++-- basis/tools/trace/trace.factor | 35 +++++++++++++++++----------- 2 files changed, 49 insertions(+), 16 deletions(-) diff --git a/basis/tools/trace/trace-tests.factor b/basis/tools/trace/trace-tests.factor index 74f7c40943..06511c7ada 100644 --- a/basis/tools/trace/trace-tests.factor +++ b/basis/tools/trace/trace-tests.factor @@ -1,4 +1,30 @@ IN: tools.trace.tests -USING: tools.trace tools.test sequences ; +USING: tools.trace tools.test tools.continuations kernel math combinators +sequences ; -[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test \ No newline at end of file +[ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] trace ] unit-test + +GENERIC: method-breakpoint-test ( x -- y ) + +TUPLE: method-breakpoint-tuple ; + +M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ; + +\ method-breakpoint-test don't-step-into + +[ 3 ] +[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] trace ] unit-test + +: case-breakpoint-test ( -- x ) + 5 { [ break 1 + ] } case ; + +\ case-breakpoint-test don't-step-into + +[ 6 ] [ [ case-breakpoint-test ] trace ] unit-test + +: call(-breakpoint-test ( -- x ) + [ break 1 ] call( -- x ) 2 + ; + +\ call(-breakpoint-test don't-step-into + +[ 3 ] [ [ call(-breakpoint-test ] trace ] unit-test diff --git a/basis/tools/trace/trace.factor b/basis/tools/trace/trace.factor index e2c6bf864b..f7f0ae4a69 100644 --- a/basis/tools/trace/trace.factor +++ b/basis/tools/trace/trace.factor @@ -4,19 +4,21 @@ USING: concurrency.promises models tools.continuations kernel sequences concurrency.messaging locals continuations threads namespaces namespaces.private make assocs accessors io strings prettyprint math math.parser words effects summary io.styles classes -generic.math combinators.short-circuit ; +generic.math combinators.short-circuit kernel.private quotations ; IN: tools.trace -: callstack-depth ( callstack -- n ) - callstack>array length 2/ ; - -SYMBOL: end - SYMBOL: exclude-vocabs SYMBOL: include-vocabs exclude-vocabs { "math" "accessors" } swap set-global +array length 2/ ; + +SYMBOL: end + : include? ( vocab -- ? ) include-vocabs get dup [ member? ] [ 2drop t ] if ; @@ -65,15 +67,20 @@ M: trace-step summary [ CHAR: \s write ] [ number>string write ": " write ] bi ; +: trace-into? ( continuation -- ? ) + continuation-current into? ; + : trace-step ( continuation -- continuation' ) - dup continuation-current end eq? [ - [ print-depth ] - [ print-step ] - [ - dup continuation-current into? - [ continuation-step-into ] [ continuation-step ] if - ] tri - ] unless ; + dup call>> innermost-frame-executing quotation? [ + dup continuation-current end eq? [ + [ print-depth ] + [ print-step ] + [ dup trace-into? [ continuation-step-into ] [ continuation-step ] if ] + tri + ] unless + ] when ; + +PRIVATE> : trace ( quot -- data ) [ [ trace-step ] break-hook ] dip From e2c73b543a59a0c68fd0d8cc8442eaedfdf0b6cd Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 10:19:23 -0400 Subject: [PATCH 29/89] Add >5 card evaluator word to poker vocab --- extra/poker/poker.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index b4353dc925..df8d93d9fa 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -2,8 +2,8 @@ ! The contents of this file are licensed under the Simplified BSD License ! A copy of the license is available at http://factorcode.org/license.txt USING: accessors arrays ascii binary-search combinators kernel locals math - math.bitwise math.order poker.arrays random sequences sequences.product - splitting ; + math.bitwise math.combinatorics math.order poker.arrays random sequences + sequences.product splitting ; IN: poker ! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with @@ -194,6 +194,9 @@ M: hand equal? : >value ( hand -- str ) hand-rank VALUE_STR nth ; +: best-hand ( str -- hand ) + " " split 5 all-combinations [ " " join ] map infimum ; + TUPLE: deck { cards sequence } ; From 0878006bd0d7b783062272a0eef1b57663995c59 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 10:29:44 -0400 Subject: [PATCH 30/89] Speed up best-hand by not converting to ckf repeatedly --- extra/poker/poker.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index df8d93d9fa..a749be239b 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -195,7 +195,8 @@ M: hand equal? hand-rank VALUE_STR nth ; : best-hand ( str -- hand ) - " " split 5 all-combinations [ " " join ] map infimum ; + parse-cards 5 all-combinations + [ dup hand-value hand boa ] map infimum ; TUPLE: deck { cards sequence } ; From 5e82d794df12897d34bc2b7a31549f2195c64048 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 10:56:33 -0400 Subject: [PATCH 31/89] Eliminate stack shuffling by using bi in PE #25 --- extra/project-euler/025/025.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor index 80a933dc63..5dfe7b9f56 100644 --- a/extra/project-euler/025/025.factor +++ b/extra/project-euler/025/025.factor @@ -39,7 +39,7 @@ IN: project-euler.025 ! Memoized brute force MEMO: fib ( m -- n ) - dup 1 > [ 1- dup fib swap 1- fib + ] when ; + dup 1 > [ [ 1 - fib ] [ 2 - fib ] bi + ] when ; Date: Thu, 7 May 2009 11:20:01 -0400 Subject: [PATCH 32/89] Add docs for best-hand in poker vocab --- extra/poker/poker-docs.factor | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index 09019a29d7..ad2131870e 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -28,3 +28,11 @@ HELP: >value "\"AC KC QC JC TC\" >value ." "\"Straight Flush\"" } } { $notes "This should not be used as a basis for hand comparison." } ; + +HELP: best-hand +{ $values { "str" string } { "hand" "a new hand" } } +{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } +{ $examples + { $example "USING: kernel poker prettyprint ;" + "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" } +} ; From 466533d509337ffb4f4c42cd4d13d169c2f10d3d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 12:32:06 -0500 Subject: [PATCH 33/89] Fix overly-eager strength reduction for mod, and add a type function for >integer (reported by Joe Groff) --- .../known-words/known-words.factor | 19 ++++++++++++------- .../tree/propagation/propagation-tests.factor | 5 ++++- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index b91a1157f7..2f5c166ac5 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b] comparison-ops [ dup '[ _ define-comparison-constraints ] each-derived-op ] each -! generic-comparison-ops [ -! dup specific-comparison define-comparison-constraints -! ] each - ! Remove redundant comparisons : fold-comparison ( info1 info2 word -- info ) [ [ interval>> ] bi@ ] dip interval-comparison { @@ -217,6 +213,8 @@ generic-comparison-ops [ { >float float } { fixnum>float float } { bignum>float float } + + { >integer integer } } [ '[ _ @@ -228,19 +226,26 @@ generic-comparison-ops [ ] "outputs" set-word-prop ] assoc-each +: rem-custom-inlining ( #call -- quot/f ) + second value-info literal>> dup integer? + [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; + { mod-integer-integer mod-integer-fixnum mod-fixnum-integer fixnum-mod - rem } [ [ - in-d>> second value-info >literal< - [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when + in-d>> dup first value-info interval>> [0,inf] interval-subset? + [ rem-custom-inlining ] [ drop f ] if ] "custom-inlining" set-word-prop ] each +\ rem [ + in-d>> rem-custom-inlining +] "custom-inlining" set-word-prop + { bitand-integer-integer bitand-integer-fixnum diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index eba41dbfdf..aba8dc9eda 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; ! Mutable tuples with circularity should not cause problems TUPLE: circle me ; -[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test \ No newline at end of file +[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test + +! Joe found an oversight +[ V{ integer } ] [ [ >integer ] final-classes ] unit-test \ No newline at end of file From d7b40d72a0b513f65ae235ac1b41c88009150652 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 12:33:31 -0500 Subject: [PATCH 34/89] Code cleanups --- basis/math/intervals/intervals.factor | 6 ++++-- vm/code_gc.cpp | 4 ++-- vm/cpu-x86.32.S | 8 ++------ vm/cpu-x86.64.S | 4 ++-- 4 files changed, 10 insertions(+), 12 deletions(-) diff --git a/basis/math/intervals/intervals.factor b/basis/math/intervals/intervals.factor index 0bc25605e7..767197a975 100755 --- a/basis/math/intervals/intervals.factor +++ b/basis/math/intervals/intervals.factor @@ -48,6 +48,8 @@ TUPLE: interval { from read-only } { to read-only } ; : (a,inf] ( a -- interval ) 1/0. (a,b] ; inline +: [0,inf] ( -- interval ) 0 [a,inf] ; foldable + : [-inf,inf] ( -- interval ) full-interval ; inline : compare-endpoints ( p1 p2 quot -- ? ) @@ -262,7 +264,7 @@ TUPLE: interval { from read-only } { to read-only } ; : interval-abs ( i1 -- i2 ) { { [ dup empty-interval eq? ] [ ] } - { [ dup full-interval eq? ] [ drop 0 [a,inf] ] } + { [ dup full-interval eq? ] [ drop [0,inf] ] } { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] } [ (interval-abs) points>interval ] } cond ; @@ -376,7 +378,7 @@ SYMBOL: incomparable : interval-log2 ( i1 -- i2 ) { { empty-interval [ empty-interval ] } - { full-interval [ 0 [a,inf] ] } + { full-interval [ [0,inf] ] } [ to>> first 1 max dup most-positive-fixnum > [ drop full-interval interval-log2 ] diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp index 59110d13f8..48cf8f7661 100755 --- a/vm/code_gc.cpp +++ b/vm/code_gc.cpp @@ -303,7 +303,7 @@ cell heap_size(heap *heap) } /* Compute where each block is going to go, after compaction */ - cell compute_heap_forwarding(heap *heap, unordered_map &forwarding) +cell compute_heap_forwarding(heap *heap, unordered_map &forwarding) { heap_block *scan = first_block(heap); char *address = (char *)first_block(heap); @@ -324,7 +324,7 @@ cell heap_size(heap *heap) return (cell)address - heap->seg->start; } - void compact_heap(heap *heap, unordered_map &forwarding) +void compact_heap(heap *heap, unordered_map &forwarding) { heap_block *scan = first_block(heap); diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index a1ce83932e..ff45f48066 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -1,9 +1,5 @@ #include "asm.h" -/* Note that primitive word definitions are compiled with -__attribute__((regparm 2), so the pointer to the word object is passed in EAX, -and the callstack top is passed in EDX */ - #define ARG0 %eax #define ARG1 %edx #define STACK_REG %esp @@ -59,9 +55,9 @@ DEF(bool,check_sse2,(void)): mov %edx,%eax ret -DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): +DEF(void,primitive_inline_cache_miss,(void)): mov (%esp),%ebx -DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)): +DEF(void,primitive_inline_cache_miss_tail,(void)): sub $8,%esp push %ebx call MANGLE(inline_cache_miss) diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 0ace354308..6b2faa1c0b 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -72,9 +72,9 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi call *ARG3 /* call memcpy */ ret /* return _with new stack_ */ -DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)): +DEF(void,primitive_inline_cache_miss,(void)): mov (%rsp),%rbx -DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)): +DEF(void,primitive_inline_cache_miss_tail,(void)): sub $STACK_PADDING,%rsp mov %rbx,ARG0 call MANGLE(inline_cache_miss) From 75d9946bd74980b3e31959af29147207c1c76177 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 12:54:23 -0500 Subject: [PATCH 35/89] compiler.tree.modular-arithmetic: convert >integer >fixnum into >fixnum --- basis/compiler/tests/optimizer.factor | 8 +++++++- .../modular-arithmetic/modular-arithmetic-tests.factor | 10 +++++++++- .../tree/modular-arithmetic/modular-arithmetic.factor | 8 ++++++++ 3 files changed, 24 insertions(+), 2 deletions(-) diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index f19a950711..fa1248435b 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -389,4 +389,10 @@ DEFER: loop-bbb [ f ] [ \ broken-declaration optimized? ] unit-test -[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test \ No newline at end of file +[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test + +! Modular arithmetic bug +: modular-arithmetic-bug ( a -- b ) >integer 256 mod ; + +[ 1 ] [ 257 modular-arithmetic-bug ] unit-test +[ -10 ] [ -10 modular-arithmetic-bug ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 5d6a9cdea1..6e1c32d89d 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ; ] { mod fixnum-mod } inlined? ] unit-test - [ f ] [ [ 256 mod ] { mod fixnum-mod } inlined? ] unit-test +[ f ] [ + [ + >fixnum 256 mod + ] { mod fixnum-mod } inlined? +] unit-test + [ f ] [ [ dup 0 >= [ 256 mod ] when @@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ; { integer } declare [ 256 rem ] map ] { mod fixnum-mod rem } inlined? ] unit-test + +[ [ >fixnum 255 fixnum-bitand ] ] +[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index de2600f691..31939a0d22 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -2,6 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: math math.partial-dispatch namespaces sequences sets accessors assocs words kernel memoize fry combinators +combinators.short-circuit compiler.tree compiler.tree.combinators compiler.tree.def-use @@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes ) : optimize->fixnum ( #call -- nodes ) dup redundant->fixnum? [ drop f ] when ; +: optimize->integer ( #call -- nodes ) + dup out-d>> first actually-used-by dup length 1 = [ + first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&& + [ drop { } ] when + ] [ drop ] if ; + MEMO: fixnum-coercion ( flags -- nodes ) [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ; @@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes ) M: #call optimize-modular-arithmetic* dup word>> { { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] } + { [ dup \ >integer eq? ] [ drop optimize->integer ] } { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] } [ drop ] } cond ; From 62231985349547646a3360e806e77dff3f783488 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 7 May 2009 13:01:42 -0500 Subject: [PATCH 36/89] link seeking docs to the seek descriptors --- core/io/io-docs.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 3469a81064..97b143e989 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -117,6 +117,7 @@ HELP: seek-relative } { $description "Seeks to an offset from the current position of the stream pointer." } ; +{ seek-absolute seek-relative seek-end } related-words HELP: seek-input { $values @@ -343,6 +344,10 @@ $nl { $subsection bl } "Seeking on the default output stream:" { $subsection seek-output } +"Seeking descriptors:" +{ $subsection seek-absolute } +{ $subsection seek-relative } +{ $subsection seek-end } "A pair of combinators for rebinding the " { $link output-stream } " variable:" { $subsection with-output-stream } { $subsection with-output-stream* } From 3591f6c68427925625e9fc3cfa4283428f8db307 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 14:26:08 -0500 Subject: [PATCH 37/89] Count megamorphic cache hits --- basis/compiler/constants/constants.factor | 37 +-- basis/cpu/ppc/bootstrap.factor | 5 + basis/cpu/x86/bootstrap.factor | 13 +- vm/code_block.cpp | 354 ++++++++++------------ vm/code_block.hpp | 2 + vm/dispatch.hpp | 3 + 6 files changed, 200 insertions(+), 214 deletions(-) diff --git a/basis/compiler/constants/constants.factor b/basis/compiler/constants/constants.factor index 5e0ee98606..6b383388ef 100644 --- a/basis/compiler/constants/constants.factor +++ b/basis/compiler/constants/constants.factor @@ -26,29 +26,30 @@ CONSTANT: deck-bits 18 : compiled-header-size ( -- n ) 4 bootstrap-cells ; inline ! Relocation classes -CONSTANT: rc-absolute-cell 0 -CONSTANT: rc-absolute 1 -CONSTANT: rc-relative 2 +CONSTANT: rc-absolute-cell 0 +CONSTANT: rc-absolute 1 +CONSTANT: rc-relative 2 CONSTANT: rc-absolute-ppc-2/2 3 -CONSTANT: rc-absolute-ppc-2 4 -CONSTANT: rc-relative-ppc-2 5 -CONSTANT: rc-relative-ppc-3 6 -CONSTANT: rc-relative-arm-3 7 -CONSTANT: rc-indirect-arm 8 -CONSTANT: rc-indirect-arm-pc 9 +CONSTANT: rc-absolute-ppc-2 4 +CONSTANT: rc-relative-ppc-2 5 +CONSTANT: rc-relative-ppc-3 6 +CONSTANT: rc-relative-arm-3 7 +CONSTANT: rc-indirect-arm 8 +CONSTANT: rc-indirect-arm-pc 9 ! Relocation types -CONSTANT: rt-primitive 0 -CONSTANT: rt-dlsym 1 -CONSTANT: rt-dispatch 2 -CONSTANT: rt-xt 3 -CONSTANT: rt-xt-pic 4 +CONSTANT: rt-primitive 0 +CONSTANT: rt-dlsym 1 +CONSTANT: rt-dispatch 2 +CONSTANT: rt-xt 3 +CONSTANT: rt-xt-pic 4 CONSTANT: rt-xt-pic-tail 5 -CONSTANT: rt-here 6 -CONSTANT: rt-this 7 -CONSTANT: rt-immediate 8 +CONSTANT: rt-here 6 +CONSTANT: rt-this 7 +CONSTANT: rt-immediate 8 CONSTANT: rt-stack-chain 9 -CONSTANT: rt-untagged 10 +CONSTANT: rt-untagged 10 +CONSTANT: rt-megamorphic-cache-hits 11 : rc-absolute? ( n -- ? ) ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ; diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 768b919d4f..6a00dec12f 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -226,6 +226,11 @@ CONSTANT: rs-reg 14 6 3 0 LWZ 6 0 4 CMP 5 BNE + ! megamorphic_cache_hits++ + 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel + 5 4 0 LWZ + 5 5 1 ADDI + 5 4 0 STW ! ... goto get(cache + bootstrap-cell) 3 3 4 LWZ 3 3 word-xt-offset LWZ diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 06807ce9fb..994591adcf 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -233,12 +233,13 @@ big-endian off temp0 temp2 ADD ! if(get(cache) == class) temp0 [] temp1 CMP - ! ... goto get(cache + bootstrap-cell) - [ - temp0 temp0 bootstrap-cell [+] MOV - temp0 word-xt-offset [+] JMP - ] [ ] make - [ length JNE ] [ % ] bi + bootstrap-cell 4 = 14 18 ? JNE ! Yuck! + ! megamorphic_cache_hits++ + temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel + temp1 [] 1 ADD + ! goto get(cache + bootstrap-cell) + temp0 temp0 bootstrap-cell [+] MOV + temp0 word-xt-offset [+] JMP ! fall-through on miss ] mega-lookup jit-define diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 1da16ad0a1..083f7f49e6 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -8,6 +8,159 @@ void flush_icache_for(code_block *block) flush_icache((cell)block,block->size); } +static int number_of_parameters(relocation_type type) +{ + switch(type) + { + case RT_PRIMITIVE: + case RT_XT: + case RT_XT_PIC: + case RT_XT_PIC_TAIL: + case RT_IMMEDIATE: + case RT_HERE: + case RT_UNTAGGED: + return 1; + case RT_DLSYM: + return 2; + case RT_THIS: + case RT_STACK_CHAIN: + case RT_MEGAMORPHIC_CACHE_HITS: + return 0; + default: + critical_error("Bad rel type",type); + return -1; /* Can't happen */ + } +} + +void *object_xt(cell obj) +{ + switch(tagged(obj).type()) + { + case WORD_TYPE: + return untag(obj)->xt; + case QUOTATION_TYPE: + return untag(obj)->xt; + default: + critical_error("Expected word or quotation",obj); + return NULL; + } +} + +static void *xt_pic(word *w, cell tagged_quot) +{ + if(tagged_quot == F || max_pic_size == 0) + return w->xt; + else + { + quotation *quot = untag(tagged_quot); + if(quot->compiledp == F) + return w->xt; + else + return quot->xt; + } +} + +void *word_xt_pic(word *w) +{ + return xt_pic(w,w->pic_def); +} + +void *word_xt_pic_tail(word *w) +{ + return xt_pic(w,w->pic_tail_def); +} + +/* References to undefined symbols are patched up to call this function on +image load */ +void undefined_symbol() +{ + general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); +} + +/* Look up an external library symbol referenced by a compiled code block */ +void *get_rel_symbol(array *literals, cell index) +{ + cell symbol = array_nth(literals,index); + cell library = array_nth(literals,index + 1); + + dll *d = (library == F ? NULL : untag(library)); + + if(d != NULL && !d->dll) + return (void *)undefined_symbol; + + switch(tagged(symbol).type()) + { + case BYTE_ARRAY_TYPE: + { + symbol_char *name = alien_offset(symbol); + void *sym = ffi_dlsym(d,name); + + if(sym) + return sym; + else + { + return (void *)undefined_symbol; + } + } + case ARRAY_TYPE: + { + cell i; + array *names = untag(symbol); + for(i = 0; i < array_capacity(names); i++) + { + symbol_char *name = alien_offset(array_nth(names,i)); + void *sym = ffi_dlsym(d,name); + + if(sym) + return sym; + } + return (void *)undefined_symbol; + } + default: + critical_error("Bad symbol specifier",symbol); + return (void *)undefined_symbol; + } +} + +cell compute_relocation(relocation_entry rel, cell index, code_block *compiled) +{ + array *literals = untag(compiled->literals); + cell offset = REL_OFFSET(rel) + (cell)compiled->xt(); + +#define ARG array_nth(literals,index) + + switch(REL_TYPE(rel)) + { + case RT_PRIMITIVE: + return (cell)primitives[untag_fixnum(ARG)]; + case RT_DLSYM: + return (cell)get_rel_symbol(literals,index); + case RT_IMMEDIATE: + return ARG; + case RT_XT: + return (cell)object_xt(ARG); + case RT_XT_PIC: + return (cell)word_xt_pic(untag(ARG)); + case RT_XT_PIC_TAIL: + return (cell)word_xt_pic_tail(untag(ARG)); + case RT_HERE: + return offset + (short)untag_fixnum(ARG); + case RT_THIS: + return (cell)(compiled + 1); + case RT_STACK_CHAIN: + return (cell)&stack_chain; + case RT_UNTAGGED: + return untag_fixnum(ARG); + case RT_MEGAMORPHIC_CACHE_HITS: + return (cell)&megamorphic_cache_hits; + default: + critical_error("Bad rel type",rel); + return 0; /* Can't happen */ + } + +#undef ARG +} + void iterate_relocations(code_block *compiled, relocation_iterator iter) { if(compiled->relocation != F) @@ -20,30 +173,8 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter) for(cell i = 0; i < length; i++) { relocation_entry rel = relocation->data()[i]; - iter(rel,index,compiled); - - switch(REL_TYPE(rel)) - { - case RT_PRIMITIVE: - case RT_XT: - case RT_XT_PIC: - case RT_XT_PIC_TAIL: - case RT_IMMEDIATE: - case RT_HERE: - case RT_UNTAGGED: - index++; - break; - case RT_DLSYM: - index += 2; - break; - case RT_THIS: - case RT_STACK_CHAIN: - break; - default: - critical_error("Bad rel type",rel); - return; /* Can't happen */ - } + index += number_of_parameters(REL_TYPE(rel)); } } } @@ -158,73 +289,24 @@ void copy_literal_references(code_block *compiled) } } -void *object_xt(cell obj) +/* Compute an address to store at a relocation */ +void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled) { - switch(tagged(obj).type()) - { - case WORD_TYPE: - return untag(obj)->xt; - case QUOTATION_TYPE: - return untag(obj)->xt; - default: - critical_error("Expected word or quotation",obj); - return NULL; - } -} +#ifdef FACTOR_DEBUG + tagged(compiled->literals).untag_check(); + tagged(compiled->relocation).untag_check(); +#endif -static void *xt_pic(word *w, cell tagged_quot) -{ - if(tagged_quot == F || max_pic_size == 0) - return w->xt; - else - { - quotation *quot = untag(tagged_quot); - if(quot->compiledp == F) - return w->xt; - else - return quot->xt; - } -} - -void *word_xt_pic(word *w) -{ - return xt_pic(w,w->pic_def); -} - -void *word_xt_pic_tail(word *w) -{ - return xt_pic(w,w->pic_tail_def); + store_address_in_code_block(REL_CLASS(rel), + REL_OFFSET(rel) + (cell)compiled->xt(), + compute_relocation(rel,index,compiled)); } void update_word_references_step(relocation_entry rel, cell index, code_block *compiled) { relocation_type type = REL_TYPE(rel); if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL) - { - cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); - array *literals = untag(compiled->literals); - cell obj = array_nth(literals,index); - - void *xt; - switch(type) - { - case RT_XT: - xt = object_xt(obj); - break; - case RT_XT_PIC: - xt = word_xt_pic(untag(obj)); - break; - case RT_XT_PIC_TAIL: - xt = word_xt_pic_tail(untag(obj)); - break; - default: - critical_error("Oops",type); - xt = NULL; - break; - } - - store_address_in_code_block(REL_CLASS(rel),offset,(cell)xt); - } + relocate_code_block_step(rel,index,compiled); } /* Relocate new code blocks completely; updating references to literals, @@ -325,114 +407,6 @@ void mark_object_code_block(object *object) } } -/* References to undefined symbols are patched up to call this function on -image load */ -void undefined_symbol() -{ - general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL); -} - -/* Look up an external library symbol referenced by a compiled code block */ -void *get_rel_symbol(array *literals, cell index) -{ - cell symbol = array_nth(literals,index); - cell library = array_nth(literals,index + 1); - - dll *d = (library == F ? NULL : untag(library)); - - if(d != NULL && !d->dll) - return (void *)undefined_symbol; - - switch(tagged(symbol).type()) - { - case BYTE_ARRAY_TYPE: - { - symbol_char *name = alien_offset(symbol); - void *sym = ffi_dlsym(d,name); - - if(sym) - return sym; - else - { - return (void *)undefined_symbol; - } - } - case ARRAY_TYPE: - { - cell i; - array *names = untag(symbol); - for(i = 0; i < array_capacity(names); i++) - { - symbol_char *name = alien_offset(array_nth(names,i)); - void *sym = ffi_dlsym(d,name); - - if(sym) - return sym; - } - return (void *)undefined_symbol; - } - default: - critical_error("Bad symbol specifier",symbol); - return (void *)undefined_symbol; - } -} - -/* Compute an address to store at a relocation */ -void relocate_code_block_step(relocation_entry rel, cell index, code_block *compiled) -{ -#ifdef FACTOR_DEBUG - tagged(compiled->literals).untag_check(); - tagged(compiled->relocation).untag_check(); -#endif - - cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); - array *literals = untag(compiled->literals); - fixnum absolute_value; - -#define ARG array_nth(literals,index) - - switch(REL_TYPE(rel)) - { - case RT_PRIMITIVE: - absolute_value = (cell)primitives[untag_fixnum(ARG)]; - break; - case RT_DLSYM: - absolute_value = (cell)get_rel_symbol(literals,index); - break; - case RT_IMMEDIATE: - absolute_value = ARG; - break; - case RT_XT: - absolute_value = (cell)object_xt(ARG); - break; - case RT_XT_PIC: - absolute_value = (cell)word_xt_pic(untag(ARG)); - break; - case RT_XT_PIC_TAIL: - absolute_value = (cell)word_xt_pic_tail(untag(ARG)); - break; - case RT_HERE: - absolute_value = offset + (short)untag_fixnum(ARG); - break; - case RT_THIS: - absolute_value = (cell)(compiled + 1); - break; - case RT_STACK_CHAIN: - absolute_value = (cell)&stack_chain; - break; - case RT_UNTAGGED: - absolute_value = untag_fixnum(ARG); - break; - default: - critical_error("Bad rel type",rel); - return; /* Can't happen */ - } - -#undef ARG - - store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); -} - /* Perform all fixups on a code block */ void relocate_code_block(code_block *compiled) { diff --git a/vm/code_block.hpp b/vm/code_block.hpp index b30de9d148..fef5b15da4 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -24,6 +24,8 @@ enum relocation_type { RT_STACK_CHAIN, /* untagged fixnum literal */ RT_UNTAGGED, + /* address of megamorphic_cache_hits var */ + RT_MEGAMORPHIC_CACHE_HITS, }; enum relocation_class { diff --git a/vm/dispatch.hpp b/vm/dispatch.hpp index f5648c7ebe..75368191a7 100644 --- a/vm/dispatch.hpp +++ b/vm/dispatch.hpp @@ -1,6 +1,9 @@ namespace factor { +extern cell megamorphic_cache_hits; +extern cell megamorphic_cache_misses; + cell lookup_method(cell object, cell methods); PRIMITIVE(lookup_method); From 246fb6672ea8b039538708be5dbd0f71c1781b7a Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 16:54:49 -0400 Subject: [PATCH 38/89] Minor logical rearrangement --- extra/poker/poker-docs.factor | 16 ++++++++-------- extra/poker/poker.factor | 8 ++++---- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index ad2131870e..ab0a59ed4f 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -12,6 +12,14 @@ HELP: } { $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ; +HELP: best-hand +{ $values { "str" string } { "hand" "a new hand" } } +{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } +{ $examples + { $example "USING: kernel poker prettyprint ;" + "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" } +} ; + HELP: >cards { $values { "hand" "a hand" } { "str" string } } { $description "Outputs a string representation of a hand's cards." } @@ -28,11 +36,3 @@ HELP: >value "\"AC KC QC JC TC\" >value ." "\"Straight Flush\"" } } { $notes "This should not be used as a basis for hand comparison." } ; - -HELP: best-hand -{ $values { "str" string } { "hand" "a new hand" } } -{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } -{ $examples - { $example "USING: kernel poker prettyprint ;" - "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" } -} ; diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index a749be239b..b7661b83db 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -188,16 +188,16 @@ M: hand equal? : ( str -- hand ) parse-cards dup hand-value hand boa ; +: best-hand ( str -- hand ) + parse-cards 5 all-combinations + [ dup hand-value hand boa ] map infimum ; + : >cards ( hand -- str ) cards>> [ card>string ] map " " join ; : >value ( hand -- str ) hand-rank VALUE_STR nth ; -: best-hand ( str -- hand ) - parse-cards 5 all-combinations - [ dup hand-value hand boa ] map infimum ; - TUPLE: deck { cards sequence } ; From 63b963e12a3d96623b2cb5f3f5e31ec21720f3a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 16:58:18 -0500 Subject: [PATCH 39/89] Fix x86-64 backend --- basis/cpu/x86/bootstrap.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor index 994591adcf..474ce2ea46 100644 --- a/basis/cpu/x86/bootstrap.factor +++ b/basis/cpu/x86/bootstrap.factor @@ -233,7 +233,7 @@ big-endian off temp0 temp2 ADD ! if(get(cache) == class) temp0 [] temp1 CMP - bootstrap-cell 4 = 14 18 ? JNE ! Yuck! + bootstrap-cell 4 = 14 22 ? JNE ! Yuck! ! megamorphic_cache_hits++ temp1 0 MOV rc-absolute-cell rt-megamorphic-cache-hits jit-rel temp1 [] 1 ADD From 7f6998a8154babe8dcbb36a710372d0abd86b562 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 18:33:55 -0400 Subject: [PATCH 40/89] Make next-odd public again as it's used elsewhere --- basis/math/miller-rabin/miller-rabin.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 9fd604a003..cb1d3723b4 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Doug Coleman. +! Copyright (c) 2008-2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel locals math math.functions math.ranges random sequences sets combinators.short-circuit math.bitwise @@ -13,8 +13,6 @@ IN: math.miller-rabin : next-even ( m -- n ) >even 2 + ; -: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; - TUPLE: positive-even-expected n ; :: (miller-rabin) ( n trials -- ? ) @@ -29,12 +27,14 @@ TUPLE: positive-even-expected n ; ] [ r iota [ 2^ s * a swap n ^mod n - -1 = - ] any? not + ] any? not ] if ] any? not ; PRIVATE> +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; + : miller-rabin* ( n numtrials -- ? ) over { { [ dup 1 <= ] [ 3drop f ] } From d9e4f6e9cbe1df7a5f979d594a681147d9f490cc Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 18:50:46 -0400 Subject: [PATCH 41/89] Update docs/summary for poker vocab --- extra/poker/poker-docs.factor | 16 ++++++++++++---- extra/poker/summary.txt | 2 +- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index ab0a59ed4f..388239d549 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax strings ; IN: poker HELP: -{ $values { "str" string } { "hand" "a new hand" } } +{ $values { "str" string } { "hand" "a new " { $link hand } } } { $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." } { $examples { $example "USING: kernel math.order poker prettyprint ;" @@ -13,7 +13,7 @@ HELP: { $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ; HELP: best-hand -{ $values { "str" string } { "hand" "a new hand" } } +{ $values { "str" string } { "hand" "a new " { $link hand } } } { $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } { $examples { $example "USING: kernel poker prettyprint ;" @@ -21,7 +21,7 @@ HELP: best-hand } ; HELP: >cards -{ $values { "hand" "a hand" } { "str" string } } +{ $values { "hand" hand } { "str" string } } { $description "Outputs a string representation of a hand's cards." } { $examples { $example "USING: poker prettyprint ;" @@ -29,10 +29,18 @@ HELP: >cards } ; HELP: >value -{ $values { "hand" "a hand" } { "str" string } } +{ $values { "hand" hand } { "str" string } } { $description "Outputs a string representation of a hand's value." } { $examples { $example "USING: poker prettyprint ;" "\"AC KC QC JC TC\" >value ." "\"Straight Flush\"" } } { $notes "This should not be used as a basis for hand comparison." } ; + +HELP: +{ $values { "deck" "a new " { $link deck } } } +{ $description "Creates a standard deck of 52 cards." } ; + +HELP: shuffle +{ $values { "deck" deck } { "deck" "a shuffled " { $link deck } } } +{ $description "Shuffles the cards in " { $snippet "deck" } ", in-place, using the Fisher-Yates algorithm." } ; diff --git a/extra/poker/summary.txt b/extra/poker/summary.txt index c8efe851c8..8dbbe9bd74 100644 --- a/extra/poker/summary.txt +++ b/extra/poker/summary.txt @@ -1 +1 @@ -5-card poker hand evaluator +Poker hand evaluator From 25886ff453f414a0a39d72ae85c8e22aa8630f0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 19:40:25 -0500 Subject: [PATCH 42/89] cpu.ppc.bootstrap: updates --- basis/cpu/ppc/bootstrap.factor | 42 ++++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 17 deletions(-) diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor index 6a00dec12f..b09938f4b9 100644 --- a/basis/cpu/ppc/bootstrap.factor +++ b/basis/cpu/ppc/bootstrap.factor @@ -21,43 +21,48 @@ CONSTANT: rs-reg 14 : xt-save ( -- n ) stack-frame 2 bootstrap-cells - ; [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel - 11 6 profile-count-offset LWZ + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 11 3 profile-count-offset LWZ 11 11 1 tag-fixnum ADDI - 11 6 profile-count-offset STW - 11 6 word-code-offset LWZ + 11 3 profile-count-offset STW + 11 3 word-code-offset LWZ 11 11 compiled-header-size ADDI 11 MTCTR BCTR ] jit-profiling jit-define [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-this jit-rel 0 MFLR 1 1 stack-frame SUBI - 6 1 xt-save STW - stack-frame 6 LI - 6 1 next-save STW + 3 1 xt-save STW + stack-frame 3 LI + 3 1 next-save STW 0 1 lr-save stack-frame + STW ] jit-prolog jit-define [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel - 6 ds-reg 4 STWU + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-immediate jit-rel + 3 ds-reg 4 STWU ] jit-push-immediate jit-define [ - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel - 7 6 0 LWZ - 1 7 0 STW - 0 6 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel - 6 MTCTR + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-stack-chain jit-rel + 4 3 0 LWZ + 1 4 0 STW + 0 3 LOAD32 rc-absolute-ppc-2/2 rt-primitive jit-rel + 3 MTCTR BCTR ] jit-primitive jit-define [ 0 BL rc-relative-ppc-3 rt-xt-pic jit-rel ] jit-word-call jit-define -[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-jump jit-define +[ + 0 6 LOAD32 rc-absolute-ppc-2/2 rt-here jit-rel + 0 B rc-relative-ppc-3 rt-xt-pic-tail jit-rel +] jit-word-jump jit-define + +[ 0 B rc-relative-ppc-3 rt-xt jit-rel ] jit-word-special jit-define [ 3 ds-reg 0 LWZ @@ -152,6 +157,9 @@ CONSTANT: rs-reg 14 ! ! ! Polymorphic inline caches +! Don't touch r6 here; it's used to pass the tail call site +! address for tail PICs + ! Load a value from a stack position [ 4 ds-reg 0 LWZ rc-absolute-ppc-2 rt-untagged jit-rel @@ -225,7 +233,7 @@ CONSTANT: rs-reg 14 ! if(get(cache) == class) 6 3 0 LWZ 6 0 4 CMP - 5 BNE + 10 BNE ! megamorphic_cache_hits++ 0 4 LOAD32 rc-absolute-ppc-2/2 rt-megamorphic-cache-hits jit-rel 5 4 0 LWZ From a8231893ec73151cedfc56e5b298b0a51e649842 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:46:42 -0500 Subject: [PATCH 43/89] un-private some useful words --- basis/opengl/textures/textures.factor | 26 ++++++++++++++------------ extra/noise/noise.factor | 6 +++--- 2 files changed, 17 insertions(+), 15 deletions(-) diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index d103e90bee..49725d2242 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -39,6 +39,8 @@ SLOT: display-list GENERIC: draw-scaled-texture ( dim texture -- ) +DEFER: make-texture + > first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri glTexSubImage2D ; -: make-texture ( image -- id ) - #! We use glTexSubImage2D to work around the power of 2 texture size - #! limitation - gen-texture [ - GL_TEXTURE_BIT [ - GL_TEXTURE_2D swap glBindTexture - non-power-of-2-textures? get - [ dup bitmap>> (tex-image) ] - [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if - ] do-attribs - ] keep ; - : init-texture ( -- ) GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri @@ -176,6 +166,18 @@ CONSTANT: max-texture-size { 512 512 } PRIVATE> +: make-texture ( image -- id ) + #! We use glTexSubImage2D to work around the power of 2 texture size + #! limitation + gen-texture [ + GL_TEXTURE_BIT [ + GL_TEXTURE_2D swap glBindTexture + non-power-of-2-textures? get + [ dup bitmap>> (tex-image) ] + [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if + ] do-attribs + ] keep ; + : ( image loc -- texture ) over dim>> max-texture-size [ <= ] 2all? [ ] diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index f2ca8ad59b..c28768283c 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -7,6 +7,9 @@ IN: noise : ( -- table ) 256 iota >byte-array randomize dup append ; +: with-seed ( seed quot -- ) + [ ] dip with-random ; inline + ] dip with-random ; inline - : >byte-map ( floats -- bytes ) [ 255.0 * >fixnum ] B{ } map-as ; From 2ba187210eef72382a91f4eadc684dc14810ffa5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:47:05 -0500 Subject: [PATCH 44/89] fix some faux pas in bunny --- extra/bunny/model/model.factor | 2 +- extra/bunny/outlined/outlined.factor | 2 +- extra/opengl/demo-support/demo-support.factor | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index 0009e39fa7..3871936902 100755 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -89,7 +89,7 @@ M: bunny-buffers bunny-geom GL_FLOAT 0 0 buffer-offset glNormalPointer [ nv>> "float" heap-size * buffer-offset - 3 GL_FLOAT 0 roll glVertexPointer + [ 3 GL_FLOAT 0 ] dip glVertexPointer ] [ ni>> GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 0ad2a72100..7d614ff947 100755 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -120,7 +120,7 @@ TUPLE: bunny-outlined : outlining-supported? ( -- ? ) "2.0" { - "GL_ARB_shading_objects" + "GL_ARB_shader_objects" "GL_ARB_draw_buffers" "GL_ARB_multitexture" } has-gl-version-or-extensions? { diff --git a/extra/opengl/demo-support/demo-support.factor b/extra/opengl/demo-support/demo-support.factor index 35c64d4ad1..8afbd52647 100755 --- a/extra/opengl/demo-support/demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,9 +1,9 @@ USING: arrays kernel math math.functions math.order math.vectors namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures -ui.gadgets.worlds ui.render accessors combinators ; +ui.gadgets.worlds ui.render accessors combinators literals ; IN: opengl.demo-support -: FOV ( -- x ) 2.0 sqrt 1+ ; inline +CONSTANT: FOV $[ 2.0 sqrt 1+ ] CONSTANT: MOUSE-MOTION-SCALE 0.5 CONSTANT: KEY-ROTATE-STEP 10.0 From 01546acb1c81de595de2535e6ab25ca309aea34e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:47:26 -0500 Subject: [PATCH 45/89] typo in cocoa pixel format stuff --- basis/ui/backend/cocoa/cocoa.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 5b1b4b0c2a..ef5c80dcdb 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -29,7 +29,7 @@ PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{ { fullscreen { $ NSOpenGLPFAFullScreen } } { windowed { $ NSOpenGLPFAWindow } } { accelerated { $ NSOpenGLPFAAccelerated } } - { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } } + { software-rendered { $ NSOpenGLPFARendererID $ kCGLRendererGenericFloatID } } { backing-store { $ NSOpenGLPFABackingStore } } { multisampled { $ NSOpenGLPFAMultisample } } { supersampled { $ NSOpenGLPFASupersample } } From 5c4bb80bc33c4ff715169aa1d0304ba1dc93dee1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 19:47:38 -0500 Subject: [PATCH 46/89] Update PowerPC %jump and %dispatch-label, and add PIC-related functions to cpu-ppc.hpp --- basis/cpu/ppc/ppc.factor | 11 ++++++----- vm/cpu-ppc.S | 4 +++- vm/cpu-ppc.hpp | 31 ++++++++++++++++++++++++------- 3 files changed, 33 insertions(+), 13 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index a11b0daa86..beee48e5ea 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -3,9 +3,10 @@ USING: accessors assocs sequences kernel combinators make math math.order math.ranges system namespaces locals layouts words alien alien.c-types literals cpu.architecture cpu.ppc.assembler -literals compiler.cfg.registers compiler.cfg.instructions -compiler.constants compiler.codegen compiler.codegen.fixup -compiler.cfg.intrinsics compiler.cfg.stack-frame ; +cpu.ppc.assembler.backend literals compiler.cfg.registers +compiler.cfg.instructions compiler.constants compiler.codegen +compiler.codegen.fixup compiler.cfg.intrinsics +compiler.cfg.stack-frame ; IN: cpu.ppc ! PowerPC register assignments: @@ -116,7 +117,7 @@ M: ppc stack-frame-size ( stack-frame -- i ) M: ppc %call ( word -- ) 0 BL rc-relative-ppc-3 rel-word-pic ; M: ppc %jump ( word -- ) - 0 3 LOAD32 rc-absolute-ppc-2/2 rel-here + 0 6 LOAD32 8 rc-absolute-ppc-2/2 rel-here 0 B rc-relative-ppc-3 rel-word-pic-tail ; M: ppc %jump-label ( label -- ) B ; @@ -130,7 +131,7 @@ M:: ppc %dispatch ( src temp offset -- ) BCTR ; M: ppc %dispatch-label ( word -- ) - 0 , rc-absolute-cell rel-word ; + B{ 0 0 0 0 } % rc-absolute-cell rel-word ; :: (%slot) ( obj slot tag temp -- reg offset ) temp slot obj ADD diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index f8dad4b2b2..a372b2b1f5 100755 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -236,8 +236,10 @@ DEF(void,flush_icache,(void *start, int len)): blr DEF(void,primitive_inline_cache_miss,(void)): - mflr r3 + mflr r6 +DEF(void,primitive_inline_cache_miss_tail,(void)): PROLOGUE + mr r3,r6 bl MANGLE(inline_cache_miss) EPILOGUE mtctr r3 diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index d393223d8d..ae7f93ebf7 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -7,11 +7,22 @@ namespace factor register cell ds asm("r13"); register cell rs asm("r14"); +/* In the instruction sequence: + + LOAD32 r3,... + B blah + + the offset from the immediate operand to LOAD32 to the instruction after + the branch is two instructions. */ +static const fixnum xt_tail_pic_offset = 4 * 2; + inline static void check_call_site(cell return_address) { #ifdef FACTOR_DEBUG cell insn = *(cell *)return_address; - assert((insn & 0x3) == 0x1); + /* Check that absolute bit is 0 */ + assert((insn & 0x2) == 0x0); + /* Check that instruction is branch */ assert((insn >> 26) == 0x12); #endif } @@ -21,8 +32,8 @@ inline static void check_call_site(cell return_address) inline static void *get_call_target(cell return_address) { return_address -= sizeof(cell); - check_call_site(return_address); + cell insn = *(cell *)return_address; cell unsigned_addr = (insn & B_MASK); fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6; @@ -32,19 +43,25 @@ inline static void *get_call_target(cell return_address) inline static void set_call_target(cell return_address, void *target) { return_address -= sizeof(cell); - -#ifdef FACTOR_DEBUG - assert((return_address & ~B_MASK) == 0); check_call_site(return_address); -#endif + cell insn = *(cell *)return_address; - insn = ((insn & ~B_MASK) | (((cell)target - return_address) & B_MASK)); + + fixnum relative_address = ((cell)target - return_address); + insn = ((insn & ~B_MASK) | (relative_address & B_MASK)); *(cell *)return_address = insn; /* Flush the cache line containing the call we just patched */ __asm__ __volatile__ ("icbi 0, %0\n" "sync\n"::"r" (return_address):); } +inline static bool tail_call_site_p(cell return_address) +{ + return_address -= sizeof(cell); + cell insn = *(cell *)return_address; + return (insn & 0x1) == 0; +} + /* Defined in assembly */ VM_ASM_API void c_to_factor(cell quot); VM_ASM_API void throw_impl(cell quot, stack_frame *rewind); From e833349ff8f2fdbf8221f020137953522e1fb8b4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 7 May 2009 19:53:56 -0500 Subject: [PATCH 47/89] slow, ugly, unoptimized terrain generation demo --- extra/game-loop/game-loop.factor | 4 +- extra/terrain/generation/generation.factor | 60 +++++++ extra/terrain/shaders/shaders.factor | 46 +++++ extra/terrain/terrain.factor | 190 +++++++++++++++++++++ 4 files changed, 298 insertions(+), 2 deletions(-) create mode 100644 extra/terrain/generation/generation.factor create mode 100644 extra/terrain/shaders/shaders.factor create mode 100644 extra/terrain/terrain.factor diff --git a/extra/game-loop/game-loop.factor b/extra/game-loop/game-loop.factor index 8e7c7017d4..8abbe6ba25 100644 --- a/extra/game-loop/game-loop.factor +++ b/extra/game-loop/game-loop.factor @@ -1,4 +1,4 @@ -USING: accessors destructors kernel math math.order namespaces +USING: accessors calendar destructors kernel math math.order namespaces system threads ; IN: game-loop @@ -50,7 +50,7 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5 : (run-loop) ( loop -- ) dup running?>> - [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ yield (run-loop) ] tri ] + [ [ MAX-FRAMES-TO-SKIP ?tick ] [ redraw ] [ 1 milliseconds sleep (run-loop) ] tri ] [ drop ] if ; : run-loop ( loop -- ) diff --git a/extra/terrain/generation/generation.factor b/extra/terrain/generation/generation.factor new file mode 100644 index 0000000000..18f73e8e8b --- /dev/null +++ b/extra/terrain/generation/generation.factor @@ -0,0 +1,60 @@ +USING: accessors arrays byte-arrays combinators fry grouping +images kernel math math.affine-transforms math.order +math.vectors noise random sequences ; +IN: terrain.generation + +CONSTANT: terrain-segment-size { 512 512 } +CONSTANT: terrain-big-noise-scale { 0.002 0.002 } +CONSTANT: terrain-small-noise-scale { 0.05 0.05 } + +TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ; + +: ( -- terrain ) + + 32 random-bits terrain boa ; + +: seed-at ( seed at -- seed' ) + first2 [ + ] dip [ 32 random-bits + ] curry with-seed ; + +: big-noise-segment ( terrain at -- map ) + [ big-noise-table>> terrain-big-noise-scale first2 ] dip + terrain-segment-size [ v* a. ] keep perlin-noise-byte-map ; +: small-noise-segment ( terrain at -- map ) + [ small-noise-table>> terrain-small-noise-scale first2 ] dip + terrain-segment-size [ v* a. ] keep perlin-noise-byte-map ; +: tiny-noise-segment ( terrain at -- map ) + [ tiny-noise-seed>> ] dip seed-at 0.1 + terrain-segment-size normal-noise-byte-map ; + +: padding ( terrain at -- padding ) + 2drop terrain-segment-size product 255 ; + +TUPLE: segment image ; + +: terrain-segment ( terrain at -- image ) + { + [ big-noise-segment ] + [ small-noise-segment ] + [ tiny-noise-segment ] + [ padding ] + } 2cleave + 4array flip concat >byte-array + [ terrain-segment-size RGBA f ] dip image boa ; + +: 4max ( a b c d -- max ) + max max max ; inline + +: mipmap ( {{pixels}} quot: ( aa ab ba bb -- c ) -- pixels' ) + [ [ 2 ] map 2 ] dip + '[ first2 [ [ first2 ] bi@ @ ] 2map ] map ; inline + +: group-pixels ( bitmap dim -- scanlines ) + [ 4 ] [ first ] bi* ; + +: concat-pixels ( scanlines -- bitmap ) + [ concat ] map concat ; + +: segment-mipmap ( image -- image' ) + [ clone ] [ bitmap>> ] [ dim>> ] tri + group-pixels [ 4max ] mipmap concat-pixels >>bitmap + [ 2 v/n ] change-dim ; diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor new file mode 100644 index 0000000000..2dc793f078 --- /dev/null +++ b/extra/terrain/shaders/shaders.factor @@ -0,0 +1,46 @@ +USING: multiline ; +IN: terrain.shaders + +STRING: terrain-vertex-shader + +uniform sampler2D heightmap; + +varying vec2 heightcoords; + +const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0); + +float height(sampler2D map, vec2 coords) +{ + vec4 v = texture2D(map, coords); + return dot(v, COMPONENT_SCALE); +} + +void main() +{ + gl_Position = gl_ModelViewProjectionMatrix + * (gl_Vertex + vec4(0, height(heightmap, gl_Vertex.xz), 0, 0)); + heightcoords = gl_Vertex.xz; +} + +; + +STRING: terrain-pixel-shader + +uniform sampler2D heightmap; + +varying vec2 heightcoords; + +const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0); + +float height(sampler2D map, vec2 coords) +{ + vec4 v = texture2D(map, coords); + return dot(v, COMPONENT_SCALE); +} + +void main() +{ + gl_FragColor = texture2D(heightmap, heightcoords); +} + +; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor new file mode 100644 index 0000000000..725848abb7 --- /dev/null +++ b/extra/terrain/terrain.factor @@ -0,0 +1,190 @@ +USING: accessors arrays combinators game-input +game-input.scancodes game-loop kernel literals locals math +math.constants math.functions math.matrices math.order +math.vectors opengl opengl.capabilities opengl.gl +opengl.shaders opengl.textures opengl.textures.private +sequences sequences.product specialized-arrays.float +terrain.generation terrain.shaders ui ui.gadgets +ui.gadgets.worlds ui.pixel-formats ; +IN: terrain + +CONSTANT: FOV $[ 2.0 sqrt 1+ ] +CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] +CONSTANT: FAR-PLANE 1.0 +CONSTANT: EYE-START { 0.5 0.5 1.2 } +CONSTANT: TICK-LENGTH $[ 1000 30 /i ] +CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] +CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ] + +CONSTANT: terrain-vertex-size { 512 512 } +CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } +CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] + +TUPLE: terrain-world < world + eye yaw pitch + terrain terrain-segment terrain-texture terrain-program + terrain-vertex-buffer + game-loop ; + +: frustum ( dim -- -x x -y y near far ) + dup first2 min v/n + NEAR-PLANE FOV / v*n first2 [ [ neg ] keep ] bi@ + NEAR-PLANE FAR-PLANE ; + +: set-modelview-matrix ( gadget -- ) + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_MODELVIEW glMatrixMode + glLoadIdentity + [ pitch>> 1.0 0.0 0.0 glRotatef ] + [ yaw>> 0.0 1.0 0.0 glRotatef ] + [ eye>> vneg first3 glTranslatef ] tri ; + +: vertex-array-vertex ( x z -- vertex ) + [ terrain-vertex-distance first * ] + [ terrain-vertex-distance second * ] bi* + [ 0 ] dip float-array{ } 3sequence ; + +: vertex-array-row ( z -- vertices ) + dup 1 + 2array + terrain-vertex-size first 1 + iota + 2array [ first2 swap vertex-array-vertex ] product-map + concat ; + +: vertex-array ( -- vertices ) + terrain-vertex-size second iota + [ vertex-array-row ] map concat ; + +: >vertex-buffer ( bytes -- buffer ) + [ GL_ARRAY_BUFFER ] dip GL_STATIC_DRAW ; + +: draw-vertex-buffer-row ( i -- ) + [ GL_TRIANGLE_STRIP ] dip + terrain-vertex-row-length * terrain-vertex-row-length + glDrawArrays ; + +: draw-vertex-buffer ( buffer -- ) + [ GL_ARRAY_BUFFER ] dip [ + 3 GL_FLOAT 0 f glVertexPointer + terrain-vertex-size second iota [ draw-vertex-buffer-row ] each + ] with-gl-buffer ; + +: degrees ( deg -- rad ) + pi 180.0 / * ; + +:: eye-rotate ( yaw pitch v -- v' ) + yaw degrees neg :> y + pitch degrees neg :> p + y cos :> cosy + y sin :> siny + p cos :> cosp + p sin :> sinp + + cosy 0.0 siny neg 3array + siny sinp * cosp cosy sinp * 3array + siny cosp * sinp neg cosy cosp * 3array 3array + v swap v.m ; + +: forward-vector ( world -- v ) + [ yaw>> ] [ pitch>> ] bi + { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ; +: rightward-vector ( world -- v ) + [ yaw>> ] [ pitch>> ] bi + { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; + +: move-forward ( world -- ) + dup forward-vector [ v+ ] curry change-eye drop ; +: move-backward ( world -- ) + dup forward-vector [ v- ] curry change-eye drop ; +: move-leftward ( world -- ) + dup rightward-vector [ v- ] curry change-eye drop ; +: move-rightward ( world -- ) + dup rightward-vector [ v+ ] curry change-eye drop ; + +: rotate-with-mouse ( world mouse -- ) + [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ] + [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi + drop ; + +:: handle-input ( world -- ) + read-keyboard keys>> :> keys + key-w keys nth [ world move-forward ] when + key-s keys nth [ world move-backward ] when + key-a keys nth [ world move-leftward ] when + key-d keys nth [ world move-rightward ] when + world read-mouse rotate-with-mouse + reset-mouse ; + +M: terrain-world tick* + [ handle-input ] keep + ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug + drop ; + +M: terrain-world draw* + nip draw-world ; + +: set-heightmap-texture-parameters ( texture -- ) + GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit + GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ; + +M: terrain-world begin-world + "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } + require-gl-version-or-extensions + GL_DEPTH_TEST glEnable + GL_TEXTURE_2D glEnable + GL_VERTEX_ARRAY glEnableClientState + 0.5 0.5 0.5 1.0 glClearColor + EYE-START >>eye + 0.0 >>yaw + 0.0 >>pitch + [ >>terrain ] keep + { 0 0 } terrain-segment [ >>terrain-segment ] keep + make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture + terrain-vertex-shader terrain-pixel-shader + >>terrain-program + vertex-array >vertex-buffer >>terrain-vertex-buffer + TICK-LENGTH over [ >>game-loop ] keep start-loop + reset-mouse + drop ; + +M: terrain-world end-world + { + [ game-loop>> stop-loop ] + [ terrain-vertex-buffer>> delete-gl-buffer ] + [ terrain-program>> delete-gl-program ] + [ terrain-texture>> delete-texture ] + } cleave ; + +M: terrain-world resize-world + GL_PROJECTION glMatrixMode + glLoadIdentity + dim>> [ [ 0 0 ] dip first2 glViewport ] + [ frustum glFrustum ] bi ; + +M: terrain-world draw-world* + [ set-modelview-matrix ] + [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] + [ dup terrain-program>> [ + "heightmap" glGetUniformLocation 0 glUniform1i + terrain-vertex-buffer>> draw-vertex-buffer + ] with-gl-program ] + tri gl-error ; + +M: terrain-world focusable-child* drop t ; +M: terrain-world pref-dim* drop { 640 480 } ; + +: terrain-window ( -- ) + [ + open-game-input + f T{ world-attributes + { world-class terrain-world } + { title "Terrain" } + { pixel-format-attributes { + windowed + double-buffered + T{ depth-bits { value 24 } } + } } + } open-window + ] with-ui ; From f465a013d7e93ea118df8634abf2a3cf2c2ed1d0 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 21:23:58 -0400 Subject: [PATCH 48/89] Speed up best-hands a bit using reduce and add a test --- basis/math/combinatorics/combinatorics.factor | 7 +++++++ extra/poker/poker-tests.factor | 2 ++ extra/poker/poker.factor | 6 +++--- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index 5bda23f738..bc09f9fe0f 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -116,3 +116,10 @@ PRIVATE> [ [ choose [0,b) ] keep ] dip '[ _ apply-combination @ ] each ; inline +: map-combinations ( seq k quot -- ) + [ [ choose [0,b) ] keep ] dip + '[ _ apply-combination @ ] map ; inline + +: reduce-combinations ( seq k identity quot -- result ) + [ -rot ] dip each-combination ; inline + diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index e2d89620e6..3c8e5159ab 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -26,3 +26,5 @@ IN: poker.tests [ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ = ] unit-test [ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ eq? ] unit-test + +[ 190 ] [ "AS KD JC KH 2D 2S KH" best-hand value>> ] unit-test diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index b7661b83db..baebb25572 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -179,7 +179,7 @@ PRIVATE> TUPLE: hand { cards sequence } - { value integer } ; + { value integer initial: 9999 } ; M: hand <=> [ value>> ] compare ; M: hand equal? @@ -189,8 +189,8 @@ M: hand equal? parse-cards dup hand-value hand boa ; : best-hand ( str -- hand ) - parse-cards 5 all-combinations - [ dup hand-value hand boa ] map infimum ; + parse-cards 5 hand new + [ dup hand-value hand boa min ] reduce-combinations ; : >cards ( hand -- str ) cards>> [ card>string ] map " " join ; From 5099046f9fdcc85649d92b4866de7617b4708ef9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 20:52:16 -0500 Subject: [PATCH 49/89] math.miller-rabin: make some utilities not private since math.primes uses them --- basis/math/miller-rabin/miller-rabin.factor | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 9fd604a003..88c01d5271 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -5,8 +5,6 @@ random sequences sets combinators.short-circuit math.bitwise math math.order ; IN: math.miller-rabin -odd ( n -- int ) 0 set-bit ; foldable : >even ( n -- int ) 0 clear-bit ; foldable @@ -15,7 +13,7 @@ IN: math.miller-rabin : next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; -TUPLE: positive-even-expected n ; + n-1 From cf9a09b933dcc999335377763631c19eba914248 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 20:52:39 -0500 Subject: [PATCH 50/89] images.viewer: you can now pass a pathname object to image-window and image. words --- extra/images/viewer/viewer.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index b891142d5b..b41dae9b38 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -25,7 +25,7 @@ M: image M: string load-image ; -M: pathname load-image ; +M: pathname string>> load-image ; : image-window ( object -- ) "Image" open-window ; From 3f871d3bae8933197857a7afa891456e3a5fc0ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 21:25:55 -0500 Subject: [PATCH 51/89] io.launcher.windows.nt: update unit tests for recent changes to lines and contents words --- basis/io/launcher/windows/nt/nt-tests.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor index 53b3d3ce7e..4587556e0c 100755 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -42,7 +42,7 @@ IN: io.launcher.windows.nt.tests console-vm "-run=listener" 2array >>command +closed+ >>stdin +stdout+ >>stderr - ascii [ input-stream get contents ] with-process-reader + ascii [ contents ] with-process-reader ] unit-test : launcher-test-path ( -- str ) @@ -85,7 +85,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "stderr.factor" 3array >>command "err2.txt" temp-file >>stderr - ascii lines first + ascii stream-lines first ] with-directory ] unit-test @@ -97,7 +97,7 @@ IN: io.launcher.windows.nt.tests launcher-test-path [ console-vm "-script" "env.factor" 3array >>command - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) os-envs = @@ -109,7 +109,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command +replace-environment+ >>environment-mode os-envs >>environment - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) os-envs = @@ -120,7 +120,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "A" "B" } } >>environment - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) "A" swap at @@ -132,7 +132,7 @@ IN: io.launcher.windows.nt.tests console-vm "-script" "env.factor" 3array >>command { { "USERPROFILE" "XXX" } } >>environment +prepend-environment+ >>environment-mode - ascii contents + ascii stream-contents ] with-directory eval( -- alist ) "USERPROFILE" swap at "XXX" = From 9d2fb3378b30ce1e33c4143e1297bd42cda706a5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 21:26:29 -0500 Subject: [PATCH 52/89] io.backend.windows.privileges: clean up code and fix inference problem --- .../backend/windows/privileges/privileges-tests.factor | 4 ++++ basis/io/backend/windows/privileges/privileges.factor | 9 +++++---- 2 files changed, 9 insertions(+), 4 deletions(-) create mode 100755 basis/io/backend/windows/privileges/privileges-tests.factor mode change 100644 => 100755 basis/io/backend/windows/privileges/privileges.factor diff --git a/basis/io/backend/windows/privileges/privileges-tests.factor b/basis/io/backend/windows/privileges/privileges-tests.factor new file mode 100755 index 0000000000..7237651b80 --- /dev/null +++ b/basis/io/backend/windows/privileges/privileges-tests.factor @@ -0,0 +1,4 @@ +IN: io.backend.windows.privileges.tests +USING: io.backend.windows.privileges tools.test ; + +[ [ ] with-privileges ] must-infer diff --git a/basis/io/backend/windows/privileges/privileges.factor b/basis/io/backend/windows/privileges/privileges.factor old mode 100644 new mode 100755 index 8661ba99d9..58806cc4df --- a/basis/io/backend/windows/privileges/privileges.factor +++ b/basis/io/backend/windows/privileges/privileges.factor @@ -1,12 +1,13 @@ USING: io.backend kernel continuations sequences -system vocabs.loader combinators ; +system vocabs.loader combinators fry ; IN: io.backend.windows.privileges -HOOK: set-privilege io-backend ( name ? -- ) inline +HOOK: set-privilege io-backend ( name ? -- ) : with-privileges ( seq quot -- ) - over [ [ t set-privilege ] each ] curry compose - swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline + [ '[ _ [ t set-privilege ] each @ ] ] + [ drop '[ _ [ f set-privilege ] each ] ] + 2bi [ ] cleanup ; inline { { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] } From 3a636d67c45c948d6c07f1ac3225b96da43c6fd7 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 May 2009 23:11:44 -0400 Subject: [PATCH 53/89] Fix typo in poker test/doc example --- extra/poker/poker-docs.factor | 2 +- extra/poker/poker-tests.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor index 388239d549..fef47b859c 100644 --- a/extra/poker/poker-docs.factor +++ b/extra/poker/poker-docs.factor @@ -17,7 +17,7 @@ HELP: best-hand { $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." } { $examples { $example "USING: kernel poker prettyprint ;" - "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" } + "\"AS KD JC KH 2D 2S KC\" best-hand >value ." "\"Full House\"" } } ; HELP: >cards diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor index 3c8e5159ab..6b05178462 100644 --- a/extra/poker/poker-tests.factor +++ b/extra/poker/poker-tests.factor @@ -27,4 +27,4 @@ IN: poker.tests [ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ = ] unit-test [ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ ] bi@ eq? ] unit-test -[ 190 ] [ "AS KD JC KH 2D 2S KH" best-hand value>> ] unit-test +[ 190 ] [ "AS KD JC KH 2D 2S KC" best-hand value>> ] unit-test From ff674dac22c0ce383738f9d1a156fbbf85b36bf4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 23:18:41 -0500 Subject: [PATCH 54/89] cpu.ppc: bools are 4 bytes on OS X/PowerPC --- basis/cpu/ppc/ppc.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index beee48e5ea..5a528ddd5a 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -713,3 +713,4 @@ USE: vocabs.loader } cond "complex-double" c-type t >>return-in-registers? drop +"bool" c-type 4 >>size 4 >>align drop \ No newline at end of file From e52476f108c0119d088c69c592b818e711f8a3e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 May 2009 23:26:33 -0500 Subject: [PATCH 55/89] cpu.ppc: fix alien-indirect --- basis/cpu/ppc/ppc.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index beee48e5ea..13e19d4f0e 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -652,10 +652,10 @@ M: ppc %alien-callback ( quot -- ) M: ppc %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke - 13 3 MR ; + 15 3 MR ; M: ppc %alien-indirect ( -- ) - 13 MTLR BLRL ; + 15 MTLR BLRL ; M: ppc %callback-value ( ctype -- ) ! Save top of data stack From 2b23d1dd9e15a96f7becfeafed3a49d7793c46c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 00:20:54 -0500 Subject: [PATCH 56/89] Remove silly retry word from continuations vocab --- basis/io/files/unique/unique.factor | 3 +++ core/continuations/continuations-docs.factor | 16 ---------------- core/continuations/continuations.factor | 2 -- extra/webapps/wee-url/wee-url.factor | 3 +++ 4 files changed, 6 insertions(+), 18 deletions(-) diff --git a/basis/io/files/unique/unique.factor b/basis/io/files/unique/unique.factor index 0e4338e3e0..a7ae317668 100644 --- a/basis/io/files/unique/unique.factor +++ b/basis/io/files/unique/unique.factor @@ -35,6 +35,9 @@ SYMBOL: unique-retries : random-name ( -- string ) unique-length get [ random-ch ] "" replicate-as ; +: retry ( quot: ( -- ? ) n -- ) + swap [ drop ] prepose attempt-all ; inline + : (make-unique-file) ( path prefix suffix -- path ) '[ _ _ _ random-name glue append-path diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 2c91981f13..fa8ecbe385 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -79,7 +79,6 @@ $nl { $subsection continue-with } "Continuations as control-flow:" { $subsection attempt-all } -{ $subsection retry } { $subsection with-return } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -232,21 +231,6 @@ HELP: attempt-all } } ; -HELP: retry -{ $values - { "quot" quotation } { "n" integer } -} -{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." } -{ $examples - "Try to get a 0 as a random number:" - { $unchecked-example "USING: continuations math prettyprint random ;" - "[ 5 random 0 = ] 5 retry" - "t" - } -} ; - -{ attempt-all retry } related-words - HELP: return { $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 56ac4a71e9..7681c2b089 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -155,8 +155,6 @@ ERROR: attempt-all-error ; ] { } make peek swap [ rethrow ] when ] if ; inline -: retry ( quot: ( -- ? ) n -- ) swap [ drop ] prepose attempt-all ; inline - TUPLE: condition error restarts continuation ; C: condition ( error restarts cc -- condition ) diff --git a/extra/webapps/wee-url/wee-url.factor b/extra/webapps/wee-url/wee-url.factor index bc429a0af6..8e200a4452 100644 --- a/extra/webapps/wee-url/wee-url.factor +++ b/extra/webapps/wee-url/wee-url.factor @@ -26,6 +26,9 @@ short-url "SHORT_URLS" { : random-url ( -- string ) 1 6 [a,b] random [ letter-bank random ] "" replicate-as ; +: retry ( quot: ( -- ? ) n -- ) + swap [ drop ] prepose attempt-all ; inline + : insert-short-url ( short-url -- short-url ) '[ _ dup random-url >>short insert-tuple ] 10 retry ; From f4a134892c4184491df245c048fbd923680959dd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 00:41:42 -0500 Subject: [PATCH 57/89] Retry uploads etc up to 5 times so that we don't lose a good binary if network is flaky; put git id in subject --- extra/mason/build/build.factor | 11 +++++++---- extra/mason/common/common.factor | 13 ++++++++++--- extra/mason/email/email.factor | 8 ++++---- extra/mason/release/branch/branch.factor | 10 +++++----- extra/mason/report/report.factor | 2 +- 5 files changed, 27 insertions(+), 17 deletions(-) diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 199d48dec0..5031b5d930 100644 --- a/extra/mason/build/build.factor +++ b/extra/mason/build/build.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel calendar io.directories io.encodings.utf8 -io.files io.launcher mason.child mason.cleanup mason.common -mason.help mason.release mason.report mason.email mason.notify -namespaces prettyprint ; +io.files io.launcher namespaces prettyprint mason.child mason.cleanup +mason.common mason.help mason.release mason.report mason.email +mason.notify ; IN: mason.build QUALIFIED: continuations @@ -19,7 +19,10 @@ QUALIFIED: continuations : begin-build ( -- ) "factor" [ git-id ] with-directory - [ "git-id" to-file ] [ notify-begin-build ] bi ; + [ "git-id" to-file ] + [ current-git-id set ] + [ notify-begin-build ] + tri ; : build ( -- ) create-build-dir diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index e4a9d9da13..d020c68fc4 100755 --- a/extra/mason/common/common.factor +++ b/extra/mason/common/common.factor @@ -4,9 +4,12 @@ USING: kernel namespaces sequences splitting system accessors math.functions make io io.files io.pathnames io.directories io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint combinators.short-circuit parser combinators calendar -calendar.format arrays mason.config locals system debugger ; +calendar.format arrays mason.config locals system debugger fry +continuations ; IN: mason.common +SYMBOL: current-git-id + ERROR: output-process-error output process ; M: output-process-error error. @@ -35,15 +38,19 @@ M: unix really-delete-tree delete-tree ; swap >>command 15 minutes >>timeout + +closed+ >>stdin try-output-process ; +: retry ( n quot -- ) + '[ drop @ f ] attempt-all drop ; inline + :: upload-safely ( local username host remote -- ) [let* | temp [ remote ".incomplete" append ] scp-remote [ { username "@" host ":" temp } concat ] scp [ scp-command get ] ssh [ ssh-command get ] | - { scp local scp-remote } short-running-process - { ssh host "-l" username "mv" temp remote } short-running-process + 5 [ { scp local scp-remote } short-running-process ] retry + 5 [ { ssh host "-l" username "mv" temp remote } short-running-process ] retry ] ; : eval-file ( file -- obj ) diff --git a/extra/mason/email/email.factor b/extra/mason/email/email.factor index 23203e5222..302df599b4 100644 --- a/extra/mason/email/email.factor +++ b/extra/mason/email/email.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces accessors combinators make smtp debugger -prettyprint io io.streams.string io.encodings.utf8 io.files io.sockets -mason.common mason.platform mason.config ; +prettyprint sequences io io.streams.string io.encodings.utf8 io.files +io.sockets mason.common mason.platform mason.config ; IN: mason.email : prefix-subject ( str -- str' ) @@ -18,11 +18,11 @@ IN: mason.email send-email ; : subject ( status -- str ) - { + [ current-git-id get 7 short head " -- " ] dip { { status-clean [ "clean" ] } { status-dirty [ "dirty" ] } { status-error [ "error" ] } - } case ; + } case 3append ; : email-report ( report status -- ) [ "text/html" ] dip subject email-status ; diff --git a/extra/mason/release/branch/branch.factor b/extra/mason/release/branch/branch.factor index 75ce828c28..07ec5a8bcd 100644 --- a/extra/mason/release/branch/branch.factor +++ b/extra/mason/release/branch/branch.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.directories io.files io.launcher kernel make -mason.common mason.config mason.platform namespaces prettyprint -sequences ; +namespaces prettyprint sequences mason.common mason.config +mason.platform ; IN: mason.release.branch : branch-name ( -- string ) "clean-" platform append ; @@ -21,7 +21,7 @@ IN: mason.release.branch ] { } make ; : push-to-clean-branch ( -- ) - push-to-clean-branch-cmd short-running-process ; + 5 [ push-to-clean-branch-cmd short-running-process ] retry ; : upload-clean-image-cmd ( -- args ) [ @@ -36,7 +36,7 @@ IN: mason.release.branch ] { } make ; : upload-clean-image ( -- ) - upload-clean-image-cmd short-running-process ; + 5 [ upload-clean-image-cmd short-running-process ] retry ; : (update-clean-branch) ( -- ) "factor" [ diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 7707d16299..0340941449 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -12,7 +12,7 @@ IN: mason.report target-cpu get host-name build-dir - "git-id" eval-file + current-git-id get [XML

Build report for <->/<->

From 58fdffee87af3e14a4e9a0f5db5d76c3ea01ca1d Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 8 May 2009 02:24:12 -0400 Subject: [PATCH 58/89] Make lookup indices zero-based for poker values --- extra/poker/poker.factor | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index baebb25572..a5a5a93628 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -49,21 +49,21 @@ CONSTANT: QUEEN 10 CONSTANT: KING 11 CONSTANT: ACE 12 -CONSTANT: STRAIGHT_FLUSH 1 -CONSTANT: FOUR_OF_A_KIND 2 -CONSTANT: FULL_HOUSE 3 -CONSTANT: FLUSH 4 -CONSTANT: STRAIGHT 5 -CONSTANT: THREE_OF_A_KIND 6 -CONSTANT: TWO_PAIR 7 -CONSTANT: ONE_PAIR 8 -CONSTANT: HIGH_CARD 9 +CONSTANT: STRAIGHT_FLUSH 0 +CONSTANT: FOUR_OF_A_KIND 1 +CONSTANT: FULL_HOUSE 2 +CONSTANT: FLUSH 3 +CONSTANT: STRAIGHT 4 +CONSTANT: THREE_OF_A_KIND 5 +CONSTANT: TWO_PAIR 6 +CONSTANT: ONE_PAIR 7 +CONSTANT: HIGH_CARD 8 CONSTANT: SUIT_STR { "C" "D" "H" "S" } CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" } -CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" +CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush" "Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" } : card-rank-prime ( rank -- n ) @@ -159,8 +159,8 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" [ drop "S" ] } cond ; -: hand-rank ( hand -- rank ) - value>> { +: hand-rank ( value -- rank ) + { { [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card { [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair { [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair @@ -196,7 +196,7 @@ M: hand equal? cards>> [ card>string ] map " " join ; : >value ( hand -- str ) - hand-rank VALUE_STR nth ; + value>> hand-rank VALUE_STR nth ; TUPLE: deck { cards sequence } ; From e0168580befd9dbe233aaaf5447f123da5214b00 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 02:26:05 -0500 Subject: [PATCH 59/89] mason.email: fix unit test --- extra/mason/email/email-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/mason/email/email-tests.factor b/extra/mason/email/email-tests.factor index e2afe01a56..5f48ff0d4f 100644 --- a/extra/mason/email/email-tests.factor +++ b/extra/mason/email/email-tests.factor @@ -1,10 +1,11 @@ IN: mason.email.tests USING: mason.email mason.common mason.config namespaces tools.test ; -[ "mason on linux-x86-64: error" ] [ +[ "mason on linux-x86-64: 12345 -- error" ] [ [ "linux" target-os set "x86.64" target-cpu set + "12345" current-git-id set status-error subject prefix-subject ] with-scope ] unit-test From 7a0760a0f9389e048fe5a24644ffc6f199aa6e98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 02:35:46 -0500 Subject: [PATCH 60/89] tools.deploy.shaker: strip out a few more things --- basis/tools/deploy/shaker/shaker.factor | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index e8f4238ed6..816dbb7979 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -23,7 +23,13 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show - { "cpu.x86" "command-line" "libc" "system" "environment" } + { + "command-line" + "cpu.x86" + "environment" + "libc" + "alien.strings" + } [ init-hooks get delete-at ] each deploy-threads? get [ "threads" init-hooks get delete-at @@ -36,8 +42,12 @@ IN: tools.deploy.shaker "io.backend" init-hooks get delete-at ] when strip-dictionary? [ - "compiler.units" init-hooks get delete-at - "vocabs.cache" init-hooks get delete-at + { + "compiler.units" + "vocabs" + "vocabs.cache" + "source-files.errors" + } [ init-hooks get delete-at ] each ] when ; : strip-debugger ( -- ) @@ -260,21 +270,20 @@ IN: tools.deploy.shaker compiler.errors:compiler-errors definition-observers interactive-vocabs - layouts:num-tags - layouts:num-types - layouts:tag-mask - layouts:tag-numbers - layouts:type-numbers lexer-factory print-use-hook root-cache source-files.errors:error-types + source-files.errors:error-observers vocabs:dictionary vocabs:load-vocab-hook + vocabs:vocab-observers word parser-notes } % + { } { "layouts" } strip-vocab-globals % + { } { "math.partial-dispatch" } strip-vocab-globals % { } { "peg" } strip-vocab-globals % From f2f834a234713f1847cdd489e8d7116b1d1f9644 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 02:36:09 -0500 Subject: [PATCH 61/89] Deploy hello-world with optimizing compiler since the image is smaller as a result, and this makes it pass the size test again --- extra/hello-world/deploy.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 48c14f7cba..aadffb6ae8 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-name "Hello world (console)" } - { deploy-c-types? f } - { deploy-word-props? f } - { deploy-ui? f } - { deploy-reflection 1 } - { deploy-compiler? f } { deploy-unicode? f } + { deploy-ui? f } + { deploy-compiler? t } + { deploy-name "Hello world (console)" } { deploy-io 2 } - { deploy-word-defs? f } { deploy-threads? f } - { "stop-after-last-window?" t } + { deploy-reflection 1 } { deploy-math? f } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } } From ba213bdc342bd0b0c0957ed0bea3f087aba91b34 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 13:00:34 -0500 Subject: [PATCH 62/89] make open-game-input and close-game-input do reference counting. update demos to show this --- extra/game-input/game-input-docs.factor | 4 +-- extra/game-input/game-input.factor | 48 ++++++++++++++----------- extra/key-caps/key-caps.factor | 5 +-- extra/terrain/terrain.factor | 10 +++--- 4 files changed, 38 insertions(+), 29 deletions(-) diff --git a/extra/game-input/game-input-docs.factor b/extra/game-input/game-input-docs.factor index b46cf9a295..4ef0acdaaf 100755 --- a/extra/game-input/game-input-docs.factor +++ b/extra/game-input/game-input-docs.factor @@ -27,10 +27,10 @@ ARTICLE: "game-input" "Game controller input" { $subsection mouse-state } ; HELP: open-game-input -{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ; +{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ; HELP: close-game-input -{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ; +{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ; HELP: game-input-opened? { $values { "?" "a boolean" } } diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index 8281b7bc4c..ccf5bd635b 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -1,34 +1,57 @@ -USING: arrays accessors continuations kernel system +USING: arrays accessors continuations kernel math system sequences namespaces init vocabs vocabs.loader combinators ; IN: game-input SYMBOLS: game-input-backend game-input-opened ; +game-input-opened [ 0 ] initialize + HOOK: (open-game-input) game-input-backend ( -- ) HOOK: (close-game-input) game-input-backend ( -- ) HOOK: (reset-game-input) game-input-backend ( -- ) +HOOK: get-controllers game-input-backend ( -- sequence ) + +HOOK: product-string game-input-backend ( controller -- string ) +HOOK: product-id game-input-backend ( controller -- id ) +HOOK: instance-id game-input-backend ( controller -- id ) + +HOOK: read-controller game-input-backend ( controller -- controller-state ) +HOOK: calibrate-controller game-input-backend ( controller -- ) + +HOOK: read-keyboard game-input-backend ( -- keyboard-state ) + +HOOK: read-mouse game-input-backend ( -- mouse-state ) + +HOOK: reset-mouse game-input-backend ( -- ) + : game-input-opened? ( -- ? ) - game-input-opened get ; + game-input-opened get zero? not ; +ERROR: game-input-not-open ; + : open-game-input ( -- ) game-input-opened? [ (open-game-input) - game-input-opened on - ] unless ; + ] unless + game-input-opened [ 1+ ] change-global + reset-mouse ; : close-game-input ( -- ) + game-input-opened [ + dup zero? [ game-input-not-open ] when + 1- + ] change-global game-input-opened? [ (close-game-input) reset-game-input @@ -48,12 +71,6 @@ SYMBOLS: pov-up pov-up-right pov-right pov-down-right pov-down pov-down-left pov-left pov-up-left ; -HOOK: get-controllers game-input-backend ( -- sequence ) - -HOOK: product-string game-input-backend ( controller -- string ) -HOOK: product-id game-input-backend ( controller -- id ) -HOOK: instance-id game-input-backend ( controller -- id ) - : find-controller-products ( product-id -- sequence ) get-controllers [ product-id = ] with filter ; : find-controller-instance ( product-id instance-id -- controller/f ) @@ -63,25 +80,16 @@ HOOK: instance-id game-input-backend ( controller -- id ) [ instance-id = ] 2bi* and ] with with find nip ; -HOOK: read-controller game-input-backend ( controller -- controller-state ) -HOOK: calibrate-controller game-input-backend ( controller -- ) - TUPLE: keyboard-state keys ; M: keyboard-state clone call-next-method dup keys>> clone >>keys ; -HOOK: read-keyboard game-input-backend ( -- keyboard-state ) - TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ; M: mouse-state clone call-next-method dup buttons>> clone >>buttons ; -HOOK: read-mouse game-input-backend ( -- mouse-state ) - -HOOK: reset-mouse game-input-backend ( -- ) - { { [ os windows? ] [ "game-input.dinput" require ] } { [ os macosx? ] [ "game-input.iokit" require ] } diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor index 9f86336f96..b58870fadc 100755 --- a/extra/key-caps/key-caps.factor +++ b/extra/key-caps/key-caps.factor @@ -162,18 +162,19 @@ M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ; relayout-1 ; M: key-caps-gadget graft* + open-game-input dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm drop ; M: key-caps-gadget ungraft* - alarm>> [ cancel-alarm ] when* ; + alarm>> [ cancel-alarm ] when* + close-game-input ; M: key-caps-gadget handle-gesture drop [ key-down? ] [ key-up? ] bi or not ; : key-caps ( -- ) [ - open-game-input { 5 5 } "Key Caps" open-window ] with-ui ; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 725848abb7..50c88d6f00 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -10,7 +10,7 @@ IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] -CONSTANT: FAR-PLANE 1.0 +CONSTANT: FAR-PLANE 2.0 CONSTANT: EYE-START { 0.5 0.5 1.2 } CONSTANT: TICK-LENGTH $[ 1000 30 /i ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] @@ -126,8 +126,8 @@ M: terrain-world draw* GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri ; + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; M: terrain-world begin-world "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } @@ -146,10 +146,11 @@ M: terrain-world begin-world >>terrain-program vertex-array >vertex-buffer >>terrain-vertex-buffer TICK-LENGTH over [ >>game-loop ] keep start-loop - reset-mouse + open-game-input drop ; M: terrain-world end-world + close-game-input { [ game-loop>> stop-loop ] [ terrain-vertex-buffer>> delete-gl-buffer ] @@ -177,7 +178,6 @@ M: terrain-world pref-dim* drop { 640 480 } ; : terrain-window ( -- ) [ - open-game-input f T{ world-attributes { world-class terrain-world } { title "Terrain" } From 3bf813447655a188dafa3b896cec83d3b1a25502 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 15:05:55 -0500 Subject: [PATCH 63/89] VM cleanup: replace some #defines with constants and inline functions --- vm/callstack.cpp | 18 ++++------ vm/callstack.hpp | 2 -- vm/code_block.cpp | 53 ++++++++++++++++++---------- vm/code_block.hpp | 13 +++---- vm/code_gc.cpp | 12 +++---- vm/code_gc.hpp | 6 ++-- vm/contexts.cpp | 6 ++-- vm/cpu-ppc.hpp | 2 +- vm/data_gc.cpp | 83 ++++++++++++++++++++++---------------------- vm/data_gc.hpp | 22 ++++++------ vm/data_heap.cpp | 54 ++++++++++++++-------------- vm/data_heap.hpp | 22 ++++++------ vm/image.cpp | 16 ++++----- vm/image.hpp | 4 +-- vm/layouts.hpp | 26 +++++++++----- vm/math.cpp | 39 +++++++++++++-------- vm/math.hpp | 11 +++--- vm/write_barrier.hpp | 42 +++++++++++----------- 18 files changed, 229 insertions(+), 202 deletions(-) diff --git a/vm/callstack.cpp b/vm/callstack.cpp index d9ac8d6073..e7009183e9 100755 --- a/vm/callstack.cpp +++ b/vm/callstack.cpp @@ -24,10 +24,7 @@ void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator) void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator) { - cell top = (cell)FIRST_STACK_FRAME(stack); - cell bottom = top + untag_fixnum(stack->length); - - iterate_callstack(top,bottom,iterator); + iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator); } callstack *allot_callstack(cell size) @@ -75,7 +72,7 @@ PRIMITIVE(callstack) size = 0; callstack *stack = allot_callstack(size); - memcpy(FIRST_STACK_FRAME(stack),top,size); + memcpy(stack->top(),top,size); dpush(tag(stack)); } @@ -84,7 +81,7 @@ PRIMITIVE(set_callstack) callstack *stack = untag_check(dpop()); set_callstack(stack_chain->callstack_bottom, - FIRST_STACK_FRAME(stack), + stack->top(), untag_fixnum(stack->length), memcpy); @@ -173,12 +170,11 @@ PRIMITIVE(callstack_to_array) dpush(tag(frames)); } -stack_frame *innermost_stack_frame(callstack *callstack) +stack_frame *innermost_stack_frame(callstack *stack) { - stack_frame *top = FIRST_STACK_FRAME(callstack); - cell bottom = (cell)top + untag_fixnum(callstack->length); - - stack_frame *frame = (stack_frame *)bottom - 1; + stack_frame *top = stack->top(); + stack_frame *bottom = stack->bottom(); + stack_frame *frame = bottom - 1; while(frame >= top && frame_successor(frame) >= top) frame = frame_successor(frame); diff --git a/vm/callstack.hpp b/vm/callstack.hpp index ec2e8e37d1..a128cfee47 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -6,8 +6,6 @@ inline static cell callstack_size(cell size) return sizeof(callstack) + size; } -#define FIRST_STACK_FRAME(stack) (stack_frame *)((stack) + 1) - typedef void (*CALLSTACK_ITER)(stack_frame *frame); stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom); diff --git a/vm/code_block.cpp b/vm/code_block.cpp index 083f7f49e6..c34f651750 100755 --- a/vm/code_block.cpp +++ b/vm/code_block.cpp @@ -3,6 +3,21 @@ namespace factor { +static relocation_type relocation_type_of(relocation_entry r) +{ + return (relocation_type)((r & 0xf0000000) >> 28); +} + +static relocation_class relocation_class_of(relocation_entry r) +{ + return (relocation_class)((r & 0x0f000000) >> 24); +} + +static cell relocation_offset_of(relocation_entry r) +{ + return (r & 0x00ffffff); +} + void flush_icache_for(code_block *block) { flush_icache((cell)block,block->size); @@ -125,11 +140,11 @@ void *get_rel_symbol(array *literals, cell index) cell compute_relocation(relocation_entry rel, cell index, code_block *compiled) { array *literals = untag(compiled->literals); - cell offset = REL_OFFSET(rel) + (cell)compiled->xt(); + cell offset = relocation_offset_of(rel) + (cell)compiled->xt(); #define ARG array_nth(literals,index) - switch(REL_TYPE(rel)) + switch(relocation_type_of(rel)) { case RT_PRIMITIVE: return (cell)primitives[untag_fixnum(ARG)]; @@ -174,7 +189,7 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter) { relocation_entry rel = relocation->data()[i]; iter(rel,index,compiled); - index += number_of_parameters(REL_TYPE(rel)); + index += number_of_parameters(relocation_type_of(rel)); } } } @@ -217,25 +232,25 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value) store_address_2_2((cell *)offset,absolute_value); break; case RC_ABSOLUTE_PPC_2: - store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0); + store_address_masked((cell *)offset,absolute_value,rel_absolute_ppc_2_mask,0); break; case RC_RELATIVE_PPC_2: - store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0); + store_address_masked((cell *)offset,relative_value,rel_relative_ppc_2_mask,0); break; case RC_RELATIVE_PPC_3: - store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0); + store_address_masked((cell *)offset,relative_value,rel_relative_ppc_3_mask,0); break; case RC_RELATIVE_ARM_3: store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2, - REL_RELATIVE_ARM_3_MASK,2); + rel_relative_arm_3_mask,2); break; case RC_INDIRECT_ARM: store_address_masked((cell *)offset,relative_value - sizeof(cell), - REL_INDIRECT_ARM_MASK,0); + rel_indirect_arm_mask,0); break; case RC_INDIRECT_ARM_PC: store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2, - REL_INDIRECT_ARM_MASK,0); + rel_indirect_arm_mask,0); break; default: critical_error("Bad rel class",klass); @@ -245,12 +260,12 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value) void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled) { - if(REL_TYPE(rel) == RT_IMMEDIATE) + if(relocation_type_of(rel) == RT_IMMEDIATE) { - cell offset = REL_OFFSET(rel) + (cell)(compiled + 1); + cell offset = relocation_offset_of(rel) + (cell)(compiled + 1); array *literals = untag(compiled->literals); fixnum absolute_value = array_nth(literals,index); - store_address_in_code_block(REL_CLASS(rel),offset,absolute_value); + store_address_in_code_block(relocation_class_of(rel),offset,absolute_value); } } @@ -297,14 +312,14 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp tagged(compiled->relocation).untag_check(); #endif - store_address_in_code_block(REL_CLASS(rel), - REL_OFFSET(rel) + (cell)compiled->xt(), + store_address_in_code_block(relocation_class_of(rel), + relocation_offset_of(rel) + (cell)compiled->xt(), compute_relocation(rel,index,compiled)); } void update_word_references_step(relocation_entry rel, cell index, code_block *compiled) { - relocation_type type = REL_TYPE(rel); + relocation_type type = relocation_type_of(rel); if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL) relocate_code_block_step(rel,index,compiled); } @@ -369,7 +384,7 @@ void mark_stack_frame_step(stack_frame *frame) /* Mark code blocks executing in currently active stack frames. */ void mark_active_blocks(context *stacks) { - if(collecting_gen == TENURED) + if(collecting_gen == data->tenured()) { cell top = (cell)stacks->callstack_top; cell bottom = (cell)stacks->callstack_bottom; @@ -410,7 +425,7 @@ void mark_object_code_block(object *object) /* Perform all fixups on a code block */ void relocate_code_block(code_block *compiled) { - compiled->last_scan = NURSERY; + compiled->last_scan = data->nursery(); compiled->needs_fixup = false; iterate_relocations(compiled,relocate_code_block_step); flush_icache_for(compiled); @@ -480,7 +495,7 @@ code_block *add_code_block( /* compiled header */ compiled->type = type; - compiled->last_scan = NURSERY; + compiled->last_scan = data->nursery(); compiled->needs_fixup = true; compiled->relocation = relocation.value(); @@ -499,7 +514,7 @@ code_block *add_code_block( /* next time we do a minor GC, we have to scan the code heap for literals */ - last_code_heap_scan = NURSERY; + last_code_heap_scan = data->nursery(); return compiled; } diff --git a/vm/code_block.hpp b/vm/code_block.hpp index fef5b15da4..d46cd9e885 100644 --- a/vm/code_block.hpp +++ b/vm/code_block.hpp @@ -51,17 +51,14 @@ enum relocation_class { RC_INDIRECT_ARM_PC }; -#define REL_ABSOLUTE_PPC_2_MASK 0xffff -#define REL_RELATIVE_PPC_2_MASK 0xfffc -#define REL_RELATIVE_PPC_3_MASK 0x3fffffc -#define REL_INDIRECT_ARM_MASK 0xfff -#define REL_RELATIVE_ARM_3_MASK 0xffffff +static const cell rel_absolute_ppc_2_mask = 0xffff; +static const cell rel_relative_ppc_2_mask = 0xfffc; +static const cell rel_relative_ppc_3_mask = 0x3fffffc; +static const cell rel_indirect_arm_mask = 0xfff; +static const cell rel_relative_arm_3_mask = 0xffffff; /* code relocation table consists of a table of entries for each fixup */ typedef u32 relocation_entry; -#define REL_TYPE(r) (relocation_type)(((r) & 0xf0000000) >> 28) -#define REL_CLASS(r) (relocation_class)(((r) & 0x0f000000) >> 24) -#define REL_OFFSET(r) ((r) & 0x00ffffff) void flush_icache_for(code_block *compiled); diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp index 48cf8f7661..4710a1baa0 100755 --- a/vm/code_gc.cpp +++ b/vm/code_gc.cpp @@ -22,9 +22,9 @@ void new_heap(heap *heap, cell size) static void add_to_free_list(heap *heap, free_heap_block *block) { - if(block->size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + if(block->size < free_list_count * block_size_increment) { - int index = block->size / BLOCK_SIZE_INCREMENT; + int index = block->size / block_size_increment; block->next_free = heap->free.small_blocks[index]; heap->free.small_blocks[index] = block; } @@ -45,7 +45,7 @@ void build_free_list(heap *heap, cell size) clear_free_list(heap); - size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); + size = (size + block_size_increment - 1) & ~(block_size_increment - 1); heap_block *scan = first_block(heap); free_heap_block *end = (free_heap_block *)(heap->seg->start + size); @@ -101,9 +101,9 @@ static free_heap_block *find_free_block(heap *heap, cell size) { cell attempt = size; - while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + while(attempt < free_list_count * block_size_increment) { - int index = attempt / BLOCK_SIZE_INCREMENT; + int index = attempt / block_size_increment; free_heap_block *block = heap->free.small_blocks[index]; if(block) { @@ -156,7 +156,7 @@ static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cel /* Allocate a block of memory from the mark and sweep GC heap */ heap_block *heap_allot(heap *heap, cell size) { - size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); + size = (size + block_size_increment - 1) & ~(block_size_increment - 1); free_heap_block *block = find_free_block(heap,size); if(block) diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp index ebd6349ab9..1cfafb69c2 100755 --- a/vm/code_gc.hpp +++ b/vm/code_gc.hpp @@ -1,11 +1,11 @@ namespace factor { -#define FREE_LIST_COUNT 16 -#define BLOCK_SIZE_INCREMENT 32 +static const cell free_list_count = 16; +static const cell block_size_increment = 32; struct heap_free_list { - free_heap_block *small_blocks[FREE_LIST_COUNT]; + free_heap_block *small_blocks[free_list_count]; free_heap_block *large_blocks; }; diff --git a/vm/contexts.cpp b/vm/contexts.cpp index 239b70876a..b0a27ef18f 100644 --- a/vm/contexts.cpp +++ b/vm/contexts.cpp @@ -18,12 +18,12 @@ void reset_retainstack() rs = rs_bot - sizeof(cell); } -#define RESERVED (64 * sizeof(cell)) +static const cell stack_reserved = (64 * sizeof(cell)); void fix_stacks() { - if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack(); - if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack(); + if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack(); + if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack(); } /* called before entry into foreign C code. Note that ds and rs might diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index ae7f93ebf7..b256b01c8b 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -27,7 +27,7 @@ inline static void check_call_site(cell return_address) #endif } -#define B_MASK 0x3fffffc +static const cell b_mask = 0x3fffffc; inline static void *get_call_target(cell return_address) { diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp index c9dbe9a953..bcf6387639 100755 --- a/vm/data_gc.cpp +++ b/vm/data_gc.cpp @@ -9,15 +9,15 @@ bool performing_gc; bool performing_compaction; cell collecting_gen; -/* if true, we collecting AGING space for the second time, so if it is still -full, we go on to collect TENURED */ +/* if true, we collecting aging space for the second time, so if it is still +full, we go on to collect tenured */ bool collecting_aging_again; /* in case a generation fills up in the middle of a gc, we jump back up to try collecting the next generation. */ jmp_buf gc_jmp; -gc_stats stats[MAX_GEN_COUNT]; +gc_stats stats[max_gen_count]; u64 cards_scanned; u64 decks_scanned; u64 card_scan_time; @@ -36,7 +36,7 @@ data_heap *old_data_heap; void init_data_gc() { performing_gc = false; - last_code_heap_scan = NURSERY; + last_code_heap_scan = data->nursery(); collecting_aging_again = false; } @@ -66,11 +66,11 @@ static bool should_copy_p(object *untagged) { if(in_zone(newspace,untagged)) return false; - if(collecting_gen == TENURED) + if(collecting_gen == data->tenured()) return true; - else if(HAVE_AGING_P && collecting_gen == AGING) - return !in_zone(&data->generations[TENURED],untagged); - else if(collecting_gen == NURSERY) + else if(data->have_aging_p() && collecting_gen == data->aging()) + return !in_zone(&data->generations[data->tenured()],untagged); + else if(collecting_gen == data->nursery()) return in_zone(&nursery,untagged); else { @@ -186,19 +186,19 @@ static void copy_gen_cards(cell gen) /* if we are collecting the nursery, we care about old->nursery pointers but not old->aging pointers */ - if(collecting_gen == NURSERY) + if(collecting_gen == data->nursery()) { - mask = CARD_POINTS_TO_NURSERY; + mask = card_points_to_nursery; /* after the collection, no old->nursery pointers remain anywhere, but old->aging pointers might remain in tenured space */ - if(gen == TENURED) - unmask = CARD_POINTS_TO_NURSERY; + if(gen == data->tenured()) + unmask = card_points_to_nursery; /* after the collection, all cards in aging space can be cleared */ - else if(HAVE_AGING_P && gen == AGING) - unmask = CARD_MARK_MASK; + else if(data->have_aging_p() && gen == data->aging()) + unmask = card_mark_mask; else { critical_error("bug in copy_gen_cards",gen); @@ -208,20 +208,20 @@ static void copy_gen_cards(cell gen) /* if we are collecting aging space into tenured space, we care about all old->nursery and old->aging pointers. no old->aging pointers can remain */ - else if(HAVE_AGING_P && collecting_gen == AGING) + else if(data->have_aging_p() && collecting_gen == data->aging()) { if(collecting_aging_again) { - mask = CARD_POINTS_TO_AGING; - unmask = CARD_MARK_MASK; + mask = card_points_to_aging; + unmask = card_mark_mask; } /* after we collect aging space into the aging semispace, no old->nursery pointers remain but tenured space might still have pointers to aging space. */ else { - mask = CARD_POINTS_TO_AGING; - unmask = CARD_POINTS_TO_NURSERY; + mask = card_points_to_aging; + unmask = card_points_to_nursery; } } else @@ -366,8 +366,8 @@ static cell copy_next_from_aging(cell scan) { obj++; - cell tenured_start = data->generations[TENURED].start; - cell tenured_end = data->generations[TENURED].end; + cell tenured_start = data->generations[data->tenured()].start; + cell tenured_end = data->generations[data->tenured()].end; cell newspace_start = newspace->start; cell newspace_end = newspace->end; @@ -421,17 +421,17 @@ static cell copy_next_from_tenured(cell scan) void copy_reachable_objects(cell scan, cell *end) { - if(collecting_gen == NURSERY) + if(collecting_gen == data->nursery()) { while(scan < *end) scan = copy_next_from_nursery(scan); } - else if(HAVE_AGING_P && collecting_gen == AGING) + else if(data->have_aging_p() && collecting_gen == data->aging()) { while(scan < *end) scan = copy_next_from_aging(scan); } - else if(collecting_gen == TENURED) + else if(collecting_gen == data->tenured()) { while(scan < *end) scan = copy_next_from_tenured(scan); @@ -443,12 +443,12 @@ static void begin_gc(cell requested_bytes) { if(growing_data_heap) { - if(collecting_gen != TENURED) + if(collecting_gen != data->tenured()) critical_error("Invalid parameters to begin_gc",0); old_data_heap = data; set_data_heap(grow_data_heap(old_data_heap,requested_bytes)); - newspace = &data->generations[TENURED]; + newspace = &data->generations[data->tenured()]; } else if(collecting_accumulation_gen_p()) { @@ -491,12 +491,12 @@ static void end_gc(cell gc_elapsed) if(collecting_accumulation_gen_p()) { /* all younger generations except are now empty. - if collecting_gen == NURSERY here, we only have 1 generation; + if collecting_gen == data->nursery() here, we only have 1 generation; old-school Cheney collector */ - if(collecting_gen != NURSERY) - reset_generations(NURSERY,collecting_gen - 1); + if(collecting_gen != data->nursery()) + reset_generations(data->nursery(),collecting_gen - 1); } - else if(collecting_gen == NURSERY) + else if(collecting_gen == data->nursery()) { nursery.here = nursery.start; } @@ -504,7 +504,7 @@ static void end_gc(cell gc_elapsed) { /* all generations up to and including the one collected are now empty */ - reset_generations(NURSERY,collecting_gen); + reset_generations(data->nursery(),collecting_gen); } collecting_aging_again = false; @@ -534,17 +534,17 @@ void garbage_collection(cell gen, { /* We have no older generations we can try collecting, so we resort to growing the data heap */ - if(collecting_gen == TENURED) + if(collecting_gen == data->tenured()) { growing_data_heap = true; /* see the comment in unmark_marked() */ unmark_marked(&code); } - /* we try collecting AGING space twice before going on to - collect TENURED */ - else if(HAVE_AGING_P - && collecting_gen == AGING + /* we try collecting aging space twice before going on to + collect tenured */ + else if(data->have_aging_p() + && collecting_gen == data->aging() && !collecting_aging_again) { collecting_aging_again = true; @@ -575,7 +575,7 @@ void garbage_collection(cell gen, { code_heap_scans++; - if(collecting_gen == TENURED) + if(collecting_gen == data->tenured()) free_unmarked(&code,(heap_iterator)update_literal_and_word_references); else copy_code_heap_roots(); @@ -595,7 +595,7 @@ void garbage_collection(cell gen, void gc() { - garbage_collection(TENURED,false,0); + garbage_collection(data->tenured(),false,0); } PRIMITIVE(gc) @@ -610,7 +610,7 @@ PRIMITIVE(gc_stats) cell i; u64 total_gc_time = 0; - for(i = 0; i < MAX_GEN_COUNT; i++) + for(i = 0; i < max_gen_count; i++) { gc_stats *s = &stats[i]; result.add(allot_cell(s->collections)); @@ -635,8 +635,7 @@ PRIMITIVE(gc_stats) void clear_gc_stats() { - int i; - for(i = 0; i < MAX_GEN_COUNT; i++) + for(cell i = 0; i < max_gen_count; i++) memset(&stats[i],0,sizeof(gc_stats)); cards_scanned = 0; @@ -683,7 +682,7 @@ PRIMITIVE(become) VM_C_API void minor_gc() { - garbage_collection(NURSERY,false,0); + garbage_collection(data->nursery(),false,0); } } diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp index 01bff2ef68..2d6a1ab897 100755 --- a/vm/data_gc.hpp +++ b/vm/data_gc.hpp @@ -24,10 +24,10 @@ void gc(); inline static bool collecting_accumulation_gen_p() { - return ((HAVE_AGING_P - && collecting_gen == AGING + return ((data->have_aging_p() + && collecting_gen == data->aging() && !collecting_aging_again) - || collecting_gen == TENURED); + || collecting_gen == data->tenured()); } void copy_handle(cell *handle); @@ -39,7 +39,7 @@ void garbage_collection(volatile cell gen, /* We leave this many bytes free at the top of the nursery so that inline allocation (which does not call GC because of possible roots in volatile registers) does not run out of memory */ -#define ALLOT_BUFFER_ZONE 1024 +static const cell allot_buffer_zone = 1024; inline static object *allot_zone(zone *z, cell a) { @@ -63,11 +63,11 @@ inline static object *allot_object(header header, cell size) object *obj; - if(nursery.size - ALLOT_BUFFER_ZONE > size) + if(nursery.size - allot_buffer_zone > size) { /* If there is insufficient room, collect the nursery */ - if(nursery.here + ALLOT_BUFFER_ZONE + size > nursery.end) - garbage_collection(NURSERY,false,0); + if(nursery.here + allot_buffer_zone + size > nursery.end) + garbage_collection(data->nursery(),false,0); cell h = nursery.here; nursery.here = h + align8(size); @@ -77,20 +77,20 @@ inline static object *allot_object(header header, cell size) tenured space */ else { - zone *tenured = &data->generations[TENURED]; + zone *tenured = &data->generations[data->tenured()]; /* If tenured space does not have enough room, collect */ if(tenured->here + size > tenured->end) { gc(); - tenured = &data->generations[TENURED]; + tenured = &data->generations[data->tenured()]; } /* If it still won't fit, grow the heap */ if(tenured->here + size > tenured->end) { - garbage_collection(TENURED,true,size); - tenured = &data->generations[TENURED]; + garbage_collection(data->tenured(),true,size); + tenured = &data->generations[data->tenured()]; } obj = allot_zone(tenured,size); diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index 9c84a993c8..d921d373da 100755 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -26,10 +26,10 @@ cell init_zone(zone *z, cell size, cell start) void init_card_decks() { - cell start = align(data->seg->start,DECK_SIZE); - allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS); - cards_offset = (cell)data->cards - (start >> CARD_BITS); - decks_offset = (cell)data->decks - (start >> DECK_BITS); + cell start = align(data->seg->start,deck_size); + allot_markers_offset = (cell)data->allot_markers - (start >> card_bits); + cards_offset = (cell)data->cards - (start >> card_bits); + decks_offset = (cell)data->decks - (start >> deck_bits); } data_heap *alloc_data_heap(cell gens, @@ -37,9 +37,9 @@ data_heap *alloc_data_heap(cell gens, cell aging_size, cell tenured_size) { - young_size = align(young_size,DECK_SIZE); - aging_size = align(aging_size,DECK_SIZE); - tenured_size = align(tenured_size,DECK_SIZE); + young_size = align(young_size,deck_size); + aging_size = align(aging_size,deck_size); + tenured_size = align(tenured_size,deck_size); data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap)); data->young_size = young_size; @@ -58,42 +58,42 @@ data_heap *alloc_data_heap(cell gens, return NULL; /* can't happen */ } - total_size += DECK_SIZE; + total_size += deck_size; data->seg = alloc_segment(total_size); data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count); data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count); - cell cards_size = total_size >> CARD_BITS; + cell cards_size = total_size >> card_bits; data->allot_markers = (cell *)safe_malloc(cards_size); data->allot_markers_end = data->allot_markers + cards_size; data->cards = (cell *)safe_malloc(cards_size); data->cards_end = data->cards + cards_size; - cell decks_size = total_size >> DECK_BITS; + cell decks_size = total_size >> deck_bits; data->decks = (cell *)safe_malloc(decks_size); data->decks_end = data->decks + decks_size; - cell alloter = align(data->seg->start,DECK_SIZE); + cell alloter = align(data->seg->start,deck_size); - alloter = init_zone(&data->generations[TENURED],tenured_size,alloter); - alloter = init_zone(&data->semispaces[TENURED],tenured_size,alloter); + alloter = init_zone(&data->generations[data->tenured()],tenured_size,alloter); + alloter = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter); if(data->gen_count == 3) { - alloter = init_zone(&data->generations[AGING],aging_size,alloter); - alloter = init_zone(&data->semispaces[AGING],aging_size,alloter); + alloter = init_zone(&data->generations[data->aging()],aging_size,alloter); + alloter = init_zone(&data->semispaces[data->aging()],aging_size,alloter); } if(data->gen_count >= 2) { - alloter = init_zone(&data->generations[NURSERY],young_size,alloter); - alloter = init_zone(&data->semispaces[NURSERY],0,alloter); + alloter = init_zone(&data->generations[data->nursery()],young_size,alloter); + alloter = init_zone(&data->semispaces[data->nursery()],0,alloter); } - if(data->seg->end - alloter > DECK_SIZE) + if(data->seg->end - alloter > deck_size) critical_error("Bug in alloc_data_heap",alloter); return data; @@ -141,12 +141,12 @@ void clear_allot_markers(cell from, cell to) /* NOTE: reverse order due to heap layout. */ card *first_card = addr_to_allot_marker((object *)data->generations[to].start); card *last_card = addr_to_allot_marker((object *)data->generations[from].end); - memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card); + memset(first_card,invalid_allot_marker,last_card - first_card); } void reset_generation(cell i) { - zone *z = (i == NURSERY ? &nursery : &data->generations[i]); + zone *z = (i == data->nursery() ? &nursery : &data->generations[i]); z->here = z->start; if(secure_gc) @@ -169,11 +169,11 @@ void reset_generations(cell from, cell to) void set_data_heap(data_heap *data_) { data = data_; - nursery = data->generations[NURSERY]; + nursery = data->generations[data->nursery()]; init_card_decks(); - clear_cards(NURSERY,TENURED); - clear_decks(NURSERY,TENURED); - clear_allot_markers(NURSERY,TENURED); + clear_cards(data->nursery(),data->tenured()); + clear_decks(data->nursery(),data->tenured()); + clear_allot_markers(data->nursery(),data->tenured()); } void init_data_heap(cell gens, @@ -298,7 +298,7 @@ PRIMITIVE(data_room) cell gen; for(gen = 0; gen < data->gen_count; gen++) { - zone *z = (gen == NURSERY ? &nursery : &data->generations[gen]); + zone *z = (gen == data->nursery() ? &nursery : &data->generations[gen]); a.add(tag_fixnum((z->end - z->here) >> 10)); a.add(tag_fixnum((z->size) >> 10)); } @@ -314,7 +314,7 @@ cell heap_scan_ptr; /* Disables GC and activates next-object ( -- obj ) primitive */ void begin_scan() { - heap_scan_ptr = data->generations[TENURED].start; + heap_scan_ptr = data->generations[data->tenured()].start; gc_off = true; } @@ -328,7 +328,7 @@ cell next_object() if(!gc_off) general_error(ERROR_HEAP_SCAN,F,F,NULL); - if(heap_scan_ptr >= data->generations[TENURED].here) + if(heap_scan_ptr >= data->generations[data->tenured()].here) return F; object *obj = (object *)heap_scan_ptr; diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp index bec86a2d0d..567c8f9944 100644 --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -34,20 +34,22 @@ struct data_heap { cell *decks; cell *decks_end; + + /* the 0th generation is where new objects are allocated. */ + cell nursery() { return 0; } + + /* where objects hang around */ + cell aging() { return gen_count - 2; } + + /* the oldest generation */ + cell tenured() { return gen_count - 1; } + + bool have_aging_p() { return gen_count > 2; } }; extern data_heap *data; -/* the 0th generation is where new objects are allocated. */ -#define NURSERY 0 -/* where objects hang around */ -#define AGING (data->gen_count-2) -#define HAVE_AGING_P (data->gen_count>2) -/* the oldest generation */ -#define TENURED (data->gen_count-1) - -#define MIN_GEN_COUNT 1 -#define MAX_GEN_COUNT 3 +static const cell max_gen_count = 3; inline static bool in_zone(zone *z, object *pointer) { diff --git a/vm/image.cpp b/vm/image.cpp index fd547cca50..9205aad260 100755 --- a/vm/image.cpp +++ b/vm/image.cpp @@ -31,7 +31,7 @@ static void load_data_heap(FILE *file, image_header *h, vm_parameters *p) clear_gc_stats(); - zone *tenured = &data->generations[TENURED]; + zone *tenured = &data->generations[data->tenured()]; fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file); @@ -92,10 +92,10 @@ bool save_image(const vm_char *filename) return false; } - zone *tenured = &data->generations[TENURED]; + zone *tenured = &data->generations[data->tenured()]; - h.magic = IMAGE_MAGIC; - h.version = IMAGE_VERSION; + h.magic = image_magic; + h.version = image_version; h.data_relocation_base = tenured->start; h.data_size = tenured->here - tenured->start; h.code_relocation_base = code.seg->start; @@ -165,7 +165,7 @@ static void data_fixup(cell *cell) if(immediate_p(*cell)) return; - zone *tenured = &data->generations[TENURED]; + zone *tenured = &data->generations[data->tenured()]; *cell += (tenured->start - data_relocation_base); } @@ -271,7 +271,7 @@ void relocate_data() data_fixup(&bignum_pos_one); data_fixup(&bignum_neg_one); - zone *tenured = &data->generations[TENURED]; + zone *tenured = &data->generations[data->tenured()]; for(relocating = tenured->start; relocating < tenured->here; @@ -313,10 +313,10 @@ void load_image(vm_parameters *p) if(fread(&h,sizeof(image_header),1,file) != 1) fatal_error("Cannot read image header",0); - if(h.magic != IMAGE_MAGIC) + if(h.magic != image_magic) fatal_error("Bad image: magic number check failed",h.magic); - if(h.version != IMAGE_VERSION) + if(h.version != image_version) fatal_error("Bad image: version number check failed",h.version); load_data_heap(file,&h,p); diff --git a/vm/image.hpp b/vm/image.hpp index c306f322de..807a7a6bcf 100755 --- a/vm/image.hpp +++ b/vm/image.hpp @@ -1,8 +1,8 @@ namespace factor { -#define IMAGE_MAGIC 0x0f0e0d0c -#define IMAGE_VERSION 4 +static const cell image_magic = 0x0f0e0d0c; +static const cell image_version = 4; struct image_header { cell magic; diff --git a/vm/layouts.hpp b/vm/layouts.hpp index f8d114210a..42fba35741 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -23,8 +23,15 @@ inline static cell align(cell a, cell b) return (a + (b-1)) & ~(b-1); } -#define align8(a) align(a,8) -#define align_page(a) align(a,getpagesize()) +inline static cell align8(cell a) +{ + return align(a,8); +} + +inline static cell align_page(cell a) +{ + return align(a,getpagesize()); +} #define WORD_SIZE (signed)(sizeof(cell)*8) @@ -297,12 +304,6 @@ struct dll : public object { void *dll; }; -struct callstack : public object { - static const cell type_number = CALLSTACK_TYPE; - /* tagged */ - cell length; -}; - struct stack_frame { void *xt; @@ -310,6 +311,15 @@ struct stack_frame cell size; }; +struct callstack : public object { + static const cell type_number = CALLSTACK_TYPE; + /* tagged */ + cell length; + + stack_frame *top() { return (stack_frame *)(this + 1); } + stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); } +}; + struct tuple : public object { static const cell type_number = TUPLE_TYPE; /* tagged layout */ diff --git a/vm/math.cpp b/vm/math.cpp index 7a2abe7463..76f2c88f38 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -24,8 +24,8 @@ PRIMITIVE(fixnum_divint) fixnum y = untag_fixnum(dpop()); \ fixnum x = untag_fixnum(dpeek()); fixnum result = x / y; - if(result == -FIXNUM_MIN) - drepl(allot_integer(-FIXNUM_MIN)); + if(result == -fixnum_min) + drepl(allot_integer(-fixnum_min)); else drepl(tag_fixnum(result)); } @@ -34,9 +34,9 @@ PRIMITIVE(fixnum_divmod) { cell y = ((cell *)ds)[0]; cell x = ((cell *)ds)[-1]; - if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN)) + if(y == tag_fixnum(-1) && x == tag_fixnum(fixnum_min)) { - ((cell *)ds)[-1] = allot_integer(-FIXNUM_MIN); + ((cell *)ds)[-1] = allot_integer(-fixnum_min); ((cell *)ds)[0] = tag_fixnum(0); } else @@ -50,9 +50,20 @@ PRIMITIVE(fixnum_divmod) * If we're shifting right by n bits, we won't overflow as long as none of the * high WORD_SIZE-TAG_BITS-n bits are set. */ -#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1)) -#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y)))) -#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x)) +static inline fixnum sign_mask(fixnum x) +{ + return x >> (WORD_SIZE - 1); +} + +static inline fixnum branchless_max(fixnum x, fixnum y) +{ + return (x - ((x - y) & sign_mask(x - y))); +} + +static inline fixnum branchless_abs(fixnum x) +{ + return (x ^ sign_mask(x)) - sign_mask(x); +} PRIMITIVE(fixnum_shift) { @@ -63,14 +74,14 @@ PRIMITIVE(fixnum_shift) return; else if(y < 0) { - y = BRANCHLESS_MAX(y,-WORD_SIZE + 1); + y = branchless_max(y,-WORD_SIZE + 1); drepl(tag_fixnum(x >> -y)); return; } else if(y < WORD_SIZE - TAG_BITS) { fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y)); - if(!(BRANCHLESS_ABS(x) & mask)) + if(!(branchless_abs(x) & mask)) { drepl(tag_fixnum(x << y)); return; @@ -226,7 +237,7 @@ cell unbox_array_size() case FIXNUM_TYPE: { fixnum n = untag_fixnum(dpeek()); - if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX) + if(n >= 0 && n < (fixnum)array_size_max) { dpop(); return n; @@ -236,7 +247,7 @@ cell unbox_array_size() case BIGNUM_TYPE: { bignum * zero = untag(bignum_zero); - bignum * max = cell_to_bignum(ARRAY_SIZE_MAX); + bignum * max = cell_to_bignum(array_size_max); bignum * n = untag(dpeek()); if(bignum_compare(n,zero) != bignum_comparison_less && bignum_compare(n,max) == bignum_comparison_less) @@ -248,7 +259,7 @@ cell unbox_array_size() } } - general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL); + general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(array_size_max),NULL); return 0; /* can't happen */ } @@ -428,7 +439,7 @@ VM_C_API void box_unsigned_cell(cell cell) VM_C_API void box_signed_8(s64 n) { - if(n < FIXNUM_MIN || n > FIXNUM_MAX) + if(n < fixnum_min || n > fixnum_max) dpush(tag(long_long_to_bignum(n))); else dpush(tag_fixnum(n)); @@ -450,7 +461,7 @@ VM_C_API s64 to_signed_8(cell obj) VM_C_API void box_unsigned_8(u64 n) { - if(n > FIXNUM_MAX) + if(n > fixnum_max) dpush(tag(ulong_long_to_bignum(n))); else dpush(tag_fixnum(n)); diff --git a/vm/math.hpp b/vm/math.hpp index 198960d3b5..7828aa3e6c 100644 --- a/vm/math.hpp +++ b/vm/math.hpp @@ -5,10 +5,9 @@ extern cell bignum_zero; extern cell bignum_pos_one; extern cell bignum_neg_one; -#define cell_MAX (cell)(-1) -#define FIXNUM_MAX (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1) -#define FIXNUM_MIN (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1))) -#define ARRAY_SIZE_MAX ((cell)1 << (WORD_SIZE - TAG_BITS - 2)) +static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1); +static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1))); +static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2)); PRIMITIVE(fixnum_add); PRIMITIVE(fixnum_subtract); @@ -45,7 +44,7 @@ PRIMITIVE(byte_array_to_bignum); inline static cell allot_integer(fixnum x) { - if(x < FIXNUM_MIN || x > FIXNUM_MAX) + if(x < fixnum_min || x > fixnum_max) return tag(fixnum_to_bignum(x)); else return tag_fixnum(x); @@ -53,7 +52,7 @@ inline static cell allot_integer(fixnum x) inline static cell allot_cell(cell x) { - if(x > (cell)FIXNUM_MAX) + if(x > (cell)fixnum_max) return tag(cell_to_bignum(x)); else return tag_fixnum(x); diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp index eaede538ed..0006581034 100755 --- a/vm/write_barrier.hpp +++ b/vm/write_barrier.hpp @@ -12,24 +12,24 @@ VM_C_API factor::cell decks_offset; namespace factor { -/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */ -#define CARD_POINTS_TO_NURSERY 0x80 -#define CARD_POINTS_TO_AGING 0x40 -#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING) +/* if card_points_to_nursery is set, card_points_to_aging must also be set. */ +static const cell card_points_to_nursery = 0x80; +static const cell card_points_to_aging = 0x40; +static const cell card_mark_mask = (card_points_to_nursery | card_points_to_aging); typedef u8 card; -#define CARD_BITS 8 -#define CARD_SIZE (1<> CARD_BITS) + cards_offset); + return (card*)(((cell)(a) >> card_bits) + cards_offset); } inline static cell card_to_addr(card *c) { - return ((cell)c - cards_offset) << CARD_BITS; + return ((cell)c - cards_offset) << card_bits; } inline static cell card_offset(card *c) @@ -39,48 +39,48 @@ inline static cell card_offset(card *c) typedef u8 card_deck; -#define DECK_BITS (CARD_BITS + 10) -#define DECK_SIZE (1<> DECK_BITS) + decks_offset); + return (card_deck *)(((cell)a >> deck_bits) + decks_offset); } inline static cell deck_to_addr(card_deck *c) { - return ((cell)c - decks_offset) << DECK_BITS; + return ((cell)c - decks_offset) << deck_bits; } inline static card *deck_to_card(card_deck *d) { - return (card *)((((cell)d - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset); + return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset); } -#define INVALID_ALLOT_MARKER 0xff +static const cell invalid_allot_marker = 0xff; extern cell allot_markers_offset; inline static card *addr_to_allot_marker(object *a) { - return (card *)(((cell)a >> CARD_BITS) + allot_markers_offset); + return (card *)(((cell)a >> card_bits) + allot_markers_offset); } /* the write barrier must be called any time we are potentially storing a pointer from an older generation to a younger one */ inline static void write_barrier(object *obj) { - *addr_to_card((cell)obj) = CARD_MARK_MASK; - *addr_to_deck((cell)obj) = CARD_MARK_MASK; + *addr_to_card((cell)obj) = card_mark_mask; + *addr_to_deck((cell)obj) = card_mark_mask; } /* we need to remember the first object allocated in the card */ inline static void allot_barrier(object *address) { card *ptr = addr_to_allot_marker(address); - if(*ptr == INVALID_ALLOT_MARKER) - *ptr = ((cell)address & ADDR_CARD_MASK); + if(*ptr == invalid_allot_marker) + *ptr = ((cell)address & addr_card_mask); } } From 9992817c65c323ede1ca552d7781601604227294 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 15:07:15 -0500 Subject: [PATCH 64/89] input grabbing support --- basis/core-graphics/core-graphics.factor | 9 +++++++++ basis/core-graphics/types/types.factor | 5 ++++- basis/math/rectangles/rectangles.factor | 2 ++ basis/ui/backend/backend.factor | 6 +++++- basis/ui/backend/cocoa/cocoa.factor | 11 +++++++++++ basis/ui/backend/windows/windows.factor | 8 ++++++++ basis/ui/gadgets/worlds/worlds.factor | 7 +++++-- basis/ui/ui.factor | 15 ++++++++++++--- basis/windows/user32/user32.factor | 4 ++-- extra/terrain/terrain.factor | 1 + 10 files changed, 59 insertions(+), 9 deletions(-) diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 5e95e2e36e..924f7130f0 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400 FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ; +FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ; + +FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ; +FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ; + +FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ; + +FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ; + > -> release ; +M: cocoa-ui-backend (grab-input) ( handle -- ) + 0 CGAssociateMouseAndMouseCursorPosition drop + CGMainDisplayID CGDisplayHideCursor drop + window>> -> frame CGRect>rect rect-center + first2 CGWarpMouseCursorPosition drop ; + +M: cocoa-ui-backend (ungrab-input) ( handle -- ) + drop + CGMainDisplayID CGDisplayShowCursor drop + 1 CGAssociateMouseAndMouseCursorPosition drop ; + M: cocoa-ui-backend close-window ( gadget -- ) find-world [ handle>> [ diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index 24ae72740f..c2d330b9dd 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -706,6 +706,14 @@ M: windows-ui-backend beep ( -- ) : hwnd>RECT ( hwnd -- RECT ) "RECT" [ GetWindowRect win32-error=0/f ] keep ; +M: windows-ui-backend (grab-input) ( handle -- ) + 0 ShowCursor drop + hWnd>> hwnd>RECT ClipCursor drop ; +M: windows-ui-backend (ungrab-input) ( handle -- ) + drop + f ClipCursor drop + 1 ShowCursor drop ; + : fullscreen-flags ( -- n ) { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 3568559eac..eec5666f0e 100755 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -11,7 +11,7 @@ CONSTANT: default-world-pixel-format-attributes { windowed double-buffered T{ depth-bits { value 16 } } } TUPLE: world < track - active? focused? + active? focused? grab-input? layers title status status-owner text-handle handle images @@ -20,6 +20,7 @@ TUPLE: world < track TUPLE: world-attributes { world-class initial: world } + grab-input? title status gadgets @@ -63,13 +64,15 @@ M: world request-focus-on ( child gadget -- ) vertical swap new-track t >>root? t >>active? - { 0 0 } >>window-loc ; + { 0 0 } >>window-loc + f >>grab-input? ; : apply-world-attributes ( world attributes -- world ) { [ title>> >>title ] [ status>> >>status ] [ pixel-format-attributes>> >>pixel-format-attributes ] + [ grab-input?>> >>grab-input? ] [ gadgets>> [ 1 track-add ] each ] } cleave ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index b73de68e26..d53d4c6753 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -41,14 +41,23 @@ SYMBOL: windows lose-focus swap each-gesture gain-focus swap each-gesture ; +: ?grab-input ( world -- ) + dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ; + +: ?ungrab-input ( world -- ) + dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ; + : focus-world ( world -- ) t >>focused? - dup raised-window - focus-path f focus-gestures ; + [ ?grab-input ] [ + dup raised-window + focus-path f focus-gestures + ] bi ; : unfocus-world ( world -- ) f >>focused? - focus-path f swap focus-gestures ; + [ ?ungrab-input ] + [ focus-path f swap focus-gestures ] bi ; : try-to-open-window ( world -- ) { diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 1e694bcbe4..b6caa7c039 100644 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -654,7 +654,7 @@ FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ; ! FUNCTION: ClientThreadSetup ! FUNCTION: ClientToScreen ! FUNCTION: CliImmSetHotKey -! FUNCTION: ClipCursor +FUNCTION: int ClipCursor ( RECT* clipRect ) ; FUNCTION: BOOL CloseClipboard ( ) ; ! FUNCTION: CloseDesktop ! FUNCTION: CloseWindow @@ -1363,7 +1363,7 @@ CONSTANT: HWND_TOP f ! FUNCTION: SetWindowWord ! FUNCTION: SetWinEventHook ! FUNCTION: ShowCaret -! FUNCTION: ShowCursor +FUNCTION: int ShowCursor ( BOOL show ) ; ! FUNCTION: ShowOwnedPopups ! FUNCTION: ShowScrollBar ! FUNCTION: ShowStartGlass diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 50c88d6f00..3f94b93138 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -186,5 +186,6 @@ M: terrain-world pref-dim* drop { 640 480 } ; double-buffered T{ depth-bits { value 24 } } } } + { grab-input? t } } open-window ] with-ui ; From ace084b633ecff0f2a673e235eccad7fce719389 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 15:15:10 -0500 Subject: [PATCH 65/89] Need to include unistd.h --- vm/master.hpp | 1 + 1 file changed, 1 insertion(+) diff --git a/vm/master.hpp b/vm/master.hpp index 6409d65494..6164c9ea30 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -19,6 +19,7 @@ #include #include #include +#include #include /* C++ headers */ From 367724f41e8182013a9affdca7e6663d253b7e0e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 15:23:44 -0500 Subject: [PATCH 66/89] Fix Windows compile error --- vm/layouts.hpp | 5 ----- vm/math.cpp | 2 +- vm/segments.hpp | 5 +++++ 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 42fba35741..40fd699e18 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -28,11 +28,6 @@ inline static cell align8(cell a) return align(a,8); } -inline static cell align_page(cell a) -{ - return align(a,getpagesize()); -} - #define WORD_SIZE (signed)(sizeof(cell)*8) #define TAG_MASK 7 diff --git a/vm/math.cpp b/vm/math.cpp index 76f2c88f38..eff129a5c9 100755 --- a/vm/math.cpp +++ b/vm/math.cpp @@ -461,7 +461,7 @@ VM_C_API s64 to_signed_8(cell obj) VM_C_API void box_unsigned_8(u64 n) { - if(n > fixnum_max) + if(n > (u64)fixnum_max) dpush(tag(ulong_long_to_bignum(n))); else dpush(tag_fixnum(n)); diff --git a/vm/segments.hpp b/vm/segments.hpp index a715b4dabc..36b5bc747b 100644 --- a/vm/segments.hpp +++ b/vm/segments.hpp @@ -7,4 +7,9 @@ struct segment { cell end; }; +inline static cell align_page(cell a) +{ + return align(a,getpagesize()); +} + } From 2295c967fab18d4f40147cc3d4d85c86e6da4ed9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 15:49:29 -0500 Subject: [PATCH 67/89] clip to window client area when grabbing on windows --- basis/ui/backend/windows/windows.factor | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index c2d330b9dd..ba4926d97e 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations command-line shuffle opengl ui.render ascii math.bitwise locals accessors math.rectangles math.order ascii calendar io.encodings.utf16n windows.errors literals ui.pixel-formats -ui.pixel-formats.private memoize classes ; +ui.pixel-formats.private memoize classes struct-arrays ; IN: ui.backend.windows SINGLETON: windows-ui-backend @@ -703,12 +703,18 @@ M: windows-ui-backend beep ( -- ) "MONITORINFOEX" dup length over set-MONITORINFOEX-cbSize [ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ; +: client-area>RECT ( hwnd -- RECT ) + "RECT" + [ GetClientRect win32-error=0/f ] + [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ] + [ nip ] 2tri ; + : hwnd>RECT ( hwnd -- RECT ) "RECT" [ GetWindowRect win32-error=0/f ] keep ; M: windows-ui-backend (grab-input) ( handle -- ) 0 ShowCursor drop - hWnd>> hwnd>RECT ClipCursor drop ; + hWnd>> client-area>RECT ClipCursor drop ; M: windows-ui-backend (ungrab-input) ( handle -- ) drop f ClipCursor drop From 8151796b06fe36857c98a311bc3008959c730b21 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 14:09:57 -0700 Subject: [PATCH 68/89] Add missing ClientToScreen export to windows.user32 --- basis/windows/user32/user32.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 basis/windows/user32/user32.factor diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor old mode 100644 new mode 100755 index b6caa7c039..2272695953 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -652,7 +652,7 @@ FUNCTION: HDC BeginPaint ( HWND hwnd, LPPAINTSTRUCT lpPaint ) ; FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ; ! FUNCTION: ChildWindowFromPointEx ! FUNCTION: ClientThreadSetup -! FUNCTION: ClientToScreen +FUNCTION: BOOL ClientToScreen ( HWND hWnd, POINT* point ) ; ! FUNCTION: CliImmSetHotKey FUNCTION: int ClipCursor ( RECT* clipRect ) ; FUNCTION: BOOL CloseClipboard ( ) ; From 1644d882333a4882fa72c030f815af65a8c6bb9a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 16:18:56 -0500 Subject: [PATCH 69/89] add escape key to terrain demo --- extra/terrain/terrain.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 3f94b93138..6617275784 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -111,6 +111,7 @@ TUPLE: terrain-world < world key-s keys nth [ world move-backward ] when key-a keys nth [ world move-leftward ] when key-d keys nth [ world move-rightward ] when + key-escape keys nth [ world close-window ] when world read-mouse rotate-with-mouse reset-mouse ; From 66b1fdd9160db6fed629a22a9726916a03ba955e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 17:22:04 -0500 Subject: [PATCH 70/89] oops. got the game-input reference counting backward. also, let go of the mouse state in cocoa backend when closing game-input --- extra/game-input/game-input.factor | 2 +- extra/game-input/iokit/iokit.factor | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index ccf5bd635b..922906df48 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -55,7 +55,7 @@ ERROR: game-input-not-open ; game-input-opened? [ (close-game-input) reset-game-input - ] when ; + ] unless ; : with-game-input ( quot -- ) open-game-input [ close-game-input ] [ ] cleanup ; inline diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index 0cc8b5d51f..de1529f8df 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -304,6 +304,7 @@ M: iokit-game-input-backend (close-game-input) f ] change-global f +keyboard-state+ set-global + f +mouse-state+ set-global f +controller-states+ set-global ] when ; From 04a70da513d1da2ac81291307d1efe19b341cc47 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 17:41:22 -0500 Subject: [PATCH 71/89] Fix compile error in cpu-ppc.hpp --- vm/cpu-ppc.hpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index b256b01c8b..6ae2cce27d 100755 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -35,7 +35,7 @@ inline static void *get_call_target(cell return_address) check_call_site(return_address); cell insn = *(cell *)return_address; - cell unsigned_addr = (insn & B_MASK); + cell unsigned_addr = (insn & b_mask); fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6; return (void *)(signed_addr + return_address); } @@ -48,7 +48,7 @@ inline static void set_call_target(cell return_address, void *target) cell insn = *(cell *)return_address; fixnum relative_address = ((cell)target - return_address); - insn = ((insn & ~B_MASK) | (relative_address & B_MASK)); + insn = ((insn & ~b_mask) | (relative_address & b_mask)); *(cell *)return_address = insn; /* Flush the cache line containing the call we just patched */ From ea85f298d18fe3d4c7d42624effcedc40eec539e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 18:00:53 -0500 Subject: [PATCH 72/89] math.combinatorics: fix unit test and help lint --- basis/math/combinatorics/combinatorics-docs.factor | 2 +- basis/math/combinatorics/combinatorics-tests.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor index 7f40969b95..041539c981 100644 --- a/basis/math/combinatorics/combinatorics-docs.factor +++ b/basis/math/combinatorics/combinatorics-docs.factor @@ -64,7 +64,7 @@ HELP: combination { $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." } { $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." } { $examples - { $example "USING: math.combinatorics prettyprint ;" + { $example "USING: math.combinatorics sequences prettyprint ;" "6 7 iota 4 combination ." "{ 0 1 3 6 }" } { $example "USING: math.combinatorics prettyprint ;" "0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" } diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor index 1bc4bbc825..ca6ec9cb53 100644 --- a/basis/math/combinatorics/combinatorics-tests.factor +++ b/basis/math/combinatorics/combinatorics-tests.factor @@ -1,4 +1,4 @@ -USING: math.combinatorics math.combinatorics.private tools.test ; +USING: math.combinatorics math.combinatorics.private tools.test sequences ; IN: math.combinatorics.tests [ 1 ] [ 0 factorial ] unit-test From cd4530adca9aa1189a16228e60ba5ac1d959d08a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 18:47:44 -0500 Subject: [PATCH 73/89] iokit game-input backend improvements: - avoid some needless allocation when dispatching input events - some gamepads claim to be pointers too; only match actual mouses - don't mess with the calibration settings if the axis min/max attributes aren't available also, throw a more helpful error when plist> fails --- basis/cocoa/plists/plists.factor | 11 +++- extra/game-input/iokit/iokit.factor | 82 ++++++++++++++++------------- 2 files changed, 54 insertions(+), 39 deletions(-) diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor index 31b59a6eac..ceb097bb3a 100644 --- a/basis/cocoa/plists/plists.factor +++ b/basis/cocoa/plists/plists.factor @@ -4,7 +4,7 @@ USING: strings arrays hashtables assocs sequences fry macros cocoa.messages cocoa.classes cocoa.application cocoa kernel namespaces io.backend math cocoa.enumeration byte-arrays -combinators alien.c-types words core-foundation +combinators alien.c-types words core-foundation quotations core-foundation.data core-foundation.utilities ; IN: cocoa.plists @@ -41,10 +41,16 @@ DEFER: plist> *void* [ -> release "read-plist failed" throw ] when* ; MACRO: objc-class-case ( alist -- quot ) - [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ; + [ + dup callable? + [ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ] + unless + ] map '[ _ cond ] ; PRIVATE> +ERROR: invalid-plist-object object ; + : plist> ( plist -- value ) { { NSString [ (plist-NSString>) ] } @@ -53,6 +59,7 @@ PRIVATE> { NSArray [ (plist-NSArray>) ] } { NSDictionary [ (plist-NSDictionary>) ] } { NSObject [ ] } + [ invalid-plist-object ] } objc-class-case ; : read-plist ( path -- assoc ) diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index de1529f8df..42189a8787 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -8,6 +8,8 @@ IN: game-input.iokit SINGLETON: iokit-game-input-backend +SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; + iokit-game-input-backend game-input-backend set-global : hid-manager-matching ( matching-seq -- alien ) @@ -23,7 +25,6 @@ iokit-game-input-backend game-input-backend set-global CONSTANT: game-devices-matching-seq { - H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads @@ -88,17 +89,17 @@ CONSTANT: hat-switch-matching-hash game-devices-matching-seq hid-manager-matching ; : device-property ( device key -- value ) - IOHIDDeviceGetProperty plist> ; + IOHIDDeviceGetProperty [ plist> ] [ f ] if* ; : element-property ( element key -- value ) - IOHIDElementGetProperty plist> ; + IOHIDElementGetProperty [ plist> ] [ f ] if* ; : set-element-property ( element key value -- ) [ ] [ >plist ] bi* IOHIDElementSetProperty drop ; : transfer-element-property ( element from-key to-key -- ) - [ dupd element-property ] dip swap set-element-property ; + [ dupd element-property ] dip swap + [ set-element-property ] [ 2drop ] if* ; : mouse-device? ( device -- ? ) { - [ 1 1 IOHIDDeviceConformsTo ] [ 1 2 IOHIDDeviceConformsTo ] } 1|| ; @@ -113,28 +114,31 @@ CONSTANT: hat-switch-matching-hash [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi 2array ; -: button? ( {usage-page,usage} -- ? ) - first 9 = ; inline -: keyboard-key? ( {usage-page,usage} -- ? ) - first 7 = ; inline +: button? ( element -- ? ) + IOHIDElementGetUsagePage 9 = ; inline +: keyboard-key? ( element -- ? ) + IOHIDElementGetUsagePage 7 = ; inline +: axis? ( element -- ? ) + IOHIDElementGetUsagePage 1 = ; inline + : x-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 30 } = ; inline + IOHIDElementGetUsage HEX: 30 = ; inline : y-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 31 } = ; inline + IOHIDElementGetUsage HEX: 31 = ; inline : z-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 32 } = ; inline + IOHIDElementGetUsage HEX: 32 = ; inline : rx-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 33 } = ; inline + IOHIDElementGetUsage HEX: 33 = ; inline : ry-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 34 } = ; inline + IOHIDElementGetUsage HEX: 34 = ; inline : rz-axis? ( {usage-page,usage} -- ? ) - { 1 HEX: 35 } = ; inline + IOHIDElementGetUsage HEX: 35 = ; inline : slider? ( {usage-page,usage} -- ? ) - { 1 HEX: 36 } = ; inline + IOHIDElementGetUsage HEX: 36 = ; inline : wheel? ( {usage-page,usage} -- ? ) - { 1 HEX: 38 } = ; inline + IOHIDElementGetUsage HEX: 38 = ; inline : hat-switch? ( {usage-page,usage} -- ? ) - { 1 HEX: 39 } = ; inline + IOHIDElementGetUsage HEX: 39 = ; inline CONSTANT: pov-values { @@ -152,42 +156,46 @@ CONSTANT: pov-values : pov-value ( value -- pov-direction ) IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; -: record-button ( hid-value usage state -- ) - [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ; +: record-button ( hid-value element state -- ) + [ button-value ] [ IOHIDElementGetUsage 1- ] [ buttons>> ] tri* set-nth ; : record-controller ( controller-state value -- ) - dup IOHIDValueGetElement element-usage { + dup IOHIDValueGetElement { { [ dup button? ] [ rot record-button ] } - { [ dup x-axis? ] [ drop axis-value >>x drop ] } - { [ dup y-axis? ] [ drop axis-value >>y drop ] } - { [ dup z-axis? ] [ drop axis-value >>z drop ] } - { [ dup rx-axis? ] [ drop axis-value >>rx drop ] } - { [ dup ry-axis? ] [ drop axis-value >>ry drop ] } - { [ dup rz-axis? ] [ drop axis-value >>rz drop ] } - { [ dup slider? ] [ drop axis-value >>slider drop ] } - { [ dup hat-switch? ] [ drop pov-value >>pov drop ] } + { [ dup axis? ] [ { + { [ dup x-axis? ] [ drop axis-value >>x drop ] } + { [ dup y-axis? ] [ drop axis-value >>y drop ] } + { [ dup z-axis? ] [ drop axis-value >>z drop ] } + { [ dup rx-axis? ] [ drop axis-value >>rx drop ] } + { [ dup ry-axis? ] [ drop axis-value >>ry drop ] } + { [ dup rz-axis? ] [ drop axis-value >>rz drop ] } + { [ dup slider? ] [ drop axis-value >>slider drop ] } + { [ dup hat-switch? ] [ drop pov-value >>pov drop ] } + [ 3drop ] + } cond ] } [ 3drop ] } cond ; -SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; - : ?set-nth ( value nth seq -- ) 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; : record-keyboard ( value -- ) - dup IOHIDValueGetElement element-usage keyboard-key? [ + dup IOHIDValueGetElement keyboard-key? [ [ IOHIDValueGetIntegerValue c-bool> ] [ IOHIDValueGetElement IOHIDElementGetUsage ] bi +keyboard-state+ get ?set-nth ] [ drop ] if ; : record-mouse ( value -- ) - dup IOHIDValueGetElement element-usage { + dup IOHIDValueGetElement { { [ dup button? ] [ +mouse-state+ get record-button ] } - { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] } - { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] } - { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] } - { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] } + { [ dup axis? ] [ { + { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] } + { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] } + { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] } + { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] } + [ 2drop ] + } cond ] } [ 2drop ] } cond ; From 77c8f383720b54386c17a7f8474f945a9343d67e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 8 May 2009 19:16:45 -0500 Subject: [PATCH 74/89] a little bit more rice on game-input.iokit --- extra/game-input/iokit/iokit.factor | 50 ++++++++++++++++------------- 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index 42189a8787..5f09a054f9 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -1,7 +1,7 @@ USING: cocoa cocoa.plists core-foundation iokit iokit.hid kernel cocoa.enumeration destructors math.parser cocoa.application sequences locals combinators.short-circuit threads -namespaces assocs vectors arrays combinators +namespaces assocs vectors arrays combinators hints alien core-foundation.run-loop accessors sequences.private alien.c-types math parser game-input vectors ; IN: game-input.iokit @@ -99,9 +99,7 @@ CONSTANT: hat-switch-matching-hash [ set-element-property ] [ 2drop ] if* ; : mouse-device? ( device -- ? ) - { - [ 1 2 IOHIDDeviceConformsTo ] - } 1|| ; + 1 2 IOHIDDeviceConformsTo ; : controller-device? ( device -- ? ) { @@ -156,12 +154,12 @@ CONSTANT: pov-values : pov-value ( value -- pov-direction ) IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; -: record-button ( hid-value element state -- ) - [ button-value ] [ IOHIDElementGetUsage 1- ] [ buttons>> ] tri* set-nth ; +: record-button ( state hid-value element -- ) + [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ; : record-controller ( controller-state value -- ) dup IOHIDValueGetElement { - { [ dup button? ] [ rot record-button ] } + { [ dup button? ] [ record-button ] } { [ dup axis? ] [ { { [ dup x-axis? ] [ drop axis-value >>x drop ] } { [ dup y-axis? ] [ drop axis-value >>y drop ] } @@ -176,29 +174,35 @@ CONSTANT: pov-values [ 3drop ] } cond ; +HINTS: record-controller { controller-state alien } ; + : ?set-nth ( value nth seq -- ) 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; -: record-keyboard ( value -- ) - dup IOHIDValueGetElement keyboard-key? [ +: record-keyboard ( keyboard-state value -- ) + dup IOHIDValueGetElement dup keyboard-key? [ [ IOHIDValueGetIntegerValue c-bool> ] - [ IOHIDValueGetElement IOHIDElementGetUsage ] bi - +keyboard-state+ get ?set-nth - ] [ drop ] if ; + [ IOHIDElementGetUsage ] bi* + rot ?set-nth + ] [ 3drop ] if ; -: record-mouse ( value -- ) +HINTS: record-keyboard { array alien } ; + +: record-mouse ( mouse-state value -- ) dup IOHIDValueGetElement { - { [ dup button? ] [ +mouse-state+ get record-button ] } + { [ dup button? ] [ record-button ] } { [ dup axis? ] [ { - { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] } - { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] } - { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] } - { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] } - [ 2drop ] + { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] } + { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] } + { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] } + { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] } + [ 3drop ] } cond ] } - [ 2drop ] + [ 3drop ] } cond ; +HINTS: record-mouse { mouse-state alien } ; + M: iokit-game-input-backend read-mouse +mouse-state+ get ; @@ -271,8 +275,8 @@ M: iokit-game-input-backend reset-mouse { [ sender controller-device? ] [ sender +controller-states+ get at value record-controller ] } - { [ sender mouse-device? ] [ value record-mouse ] } - [ value record-keyboard ] + { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] } + [ +keyboard-state+ get value record-keyboard ] } cond ] IOHIDValueCallback ; @@ -297,7 +301,7 @@ M: iokit-game-input-backend (open-game-input) } cleave ; M: iokit-game-input-backend (reset-game-input) - { +hid-manager+ +keyboard-state+ +controller-states+ } + { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ } [ f swap set-global ] each ; M: iokit-game-input-backend (close-game-input) From b1fffc26f88283ec68986e7b37ade59cf43398fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 21:33:49 -0500 Subject: [PATCH 75/89] mason.report: Remove superfluous text --- extra/mason/report/report.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 0340941449..6e48e7cf04 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -112,8 +112,7 @@ IN: mason.report benchmark-error-vocabs-file benchmark-error-messages-file error-dump - - "Benchmark timings" + benchmarks-file eval-file benchmarks-table ] output>array ] with-report ; From 1d747ea9116df0ee43179634ab7d420d2e8ed11a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 May 2009 21:34:28 -0500 Subject: [PATCH 76/89] specialized-arrays: fix tests on PowerPC --- .../specialized-arrays-tests.factor | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index f64542fa00..1e470b699a 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -2,7 +2,8 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences specialized-arrays.int specialized-arrays.bool specialized-arrays.ushort alien.c-types accessors kernel -specialized-arrays.direct.int specialized-arrays.char arrays ; +specialized-arrays.direct.int specialized-arrays.char +specialized-arrays.uint arrays combinators ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -10,7 +11,13 @@ specialized-arrays.direct.int specialized-arrays.char arrays ; [ 2 ] [ int-array{ 1 2 3 } second ] unit-test -[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test +[ t ] [ + { t f t } >bool-array underlying>> + { 1 0 1 } "bool" heap-size { + { 1 [ >char-array ] } + { 4 [ >uint-array ] } + } case underlying>> = +] unit-test [ ushort-array{ 1234 } ] [ little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array From 9021062795d7e2d02c49303b6201a3052dac9432 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 09:49:31 -0500 Subject: [PATCH 77/89] fp-nan? was defined incorrectly. while i'm here, let's add some more float manipulation words --- core/math/math-docs.factor | 33 +++++++++++++++++++- core/math/math-tests.factor | 17 +++++++++++ core/math/math.factor | 60 +++++++++++++++++++++++++++++-------- 3 files changed, 97 insertions(+), 13 deletions(-) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index c28bf062c1..75370d6cfd 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -245,10 +245,22 @@ HELP: times { $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" } } ; +HELP: fp-special? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; + HELP: fp-nan? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; +HELP: fp-qnan? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE Quiet Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; + +HELP: fp-snan? +{ $values { "x" real } { "?" "a boolean" } } +{ $description "Tests if " { $snippet "x" } " is an IEEE Signaling Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ; + HELP: fp-infinity? { $values { "x" real } { "?" "a boolean" } } { $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } @@ -257,7 +269,26 @@ HELP: fp-infinity? { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" } } ; -{ fp-nan? fp-infinity? } related-words +HELP: fp-nan-payload +{ $values { "x" real } { "bits" integer } } +{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ; + +HELP: +{ $values { "payload" integer } { "float" float } } +{ $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." } +{ $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ; + +{ fp-special? fp-nan? fp-qnan? fp-snan? fp-infinity? fp-nan-payload } related-words + +HELP: next-float +{ $values { "m" float } { "n" float } } +{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ; + +HELP: prev-float +{ $values { "m" float } { "n" float } } +{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ; + +{ next-float prev-float } related-words HELP: real-part { $values { "z" number } { "x" real } } diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor index c2077eb790..b7cc51e669 100644 --- a/core/math/math-tests.factor +++ b/core/math/math-tests.factor @@ -12,7 +12,24 @@ IN: math.tests [ f ] [ 1/0. fp-nan? ] unit-test [ f ] [ -1/0. fp-nan? ] unit-test [ t ] [ -0/0. fp-nan? ] unit-test +[ t ] [ 1 fp-nan? ] unit-test +! [ t ] [ 1 fp-snan? ] unit-test +! [ f ] [ 1 fp-qnan? ] unit-test +[ t ] [ HEX: 8000000000001 fp-nan? ] unit-test +[ f ] [ HEX: 8000000000001 fp-snan? ] unit-test +[ t ] [ HEX: 8000000000001 fp-qnan? ] unit-test [ t ] [ 1/0. fp-infinity? ] unit-test [ t ] [ -1/0. fp-infinity? ] unit-test [ f ] [ -0/0. fp-infinity? ] unit-test + +[ f ] [ 0 fp-nan? ] unit-test +[ t ] [ 0 fp-infinity? ] unit-test + +[ 0.0 ] [ -0.0 next-float ] unit-test +[ t ] [ 1.0 dup next-float < ] unit-test +[ t ] [ -1.0 dup next-float < ] unit-test + +[ -0.0 ] [ 0.0 prev-float ] unit-test +[ t ] [ 1.0 dup prev-float > ] unit-test +[ t ] [ -1.0 dup prev-float > ] unit-test diff --git a/core/math/math.factor b/core/math/math.factor index 8e0000326f..6a087ec909 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -81,26 +81,62 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ; UNION: number real complex ; +GENERIC: fp-special? ( x -- ? ) GENERIC: fp-nan? ( x -- ? ) +GENERIC: fp-qnan? ( x -- ? ) +GENERIC: fp-snan? ( x -- ? ) +GENERIC: fp-infinity? ( x -- ? ) +GENERIC: fp-nan-payload ( x -- bits ) +M: object fp-special? + drop f ; M: object fp-nan? drop f ; - -M: float fp-nan? - double>bits -51 shift HEX: fff [ bitand ] keep = ; - -GENERIC: fp-infinity? ( x -- ? ) - +M: object fp-qnan? + drop f ; +M: object fp-snan? + drop f ; M: object fp-infinity? drop f ; +M: object fp-nan-payload + drop f ; -M: float fp-infinity? ( float -- ? ) +M: float fp-special? + double>bits -52 shift HEX: 7ff [ bitand ] keep = ; + +M: float fp-nan-payload + double>bits HEX: fffffffffffff bitand ; foldable flushable + +M: float fp-nan? + dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; + +M: float fp-qnan? + dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; + +M: float fp-snan? + dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; + +M: float fp-infinity? + dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; + +: ( payload -- nan ) + HEX: 7ff0000000000000 bitor bits>double ; foldable flushable + +: next-float ( m -- n ) double>bits - dup -52 shift HEX: 7ff [ bitand ] keep = [ - HEX: fffffffffffff bitand 0 = - ] [ - drop f - ] if ; + dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero + dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero + 1 + bits>double ! positive + ] if + ] if ; foldable flushable + +: prev-float ( m -- n ) + double>bits + dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative + dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero + 1 - bits>double ! positive non-zero + ] if + ] if ; foldable flushable : next-power-of-2 ( m -- n ) dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline From a66de23b54299dabfbae1147e0a25259d7dba443 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 11:15:06 -0500 Subject: [PATCH 78/89] gravity, jetpack, collision detection for terrain demo --- extra/terrain/shaders/shaders.factor | 10 +-- extra/terrain/terrain.factor | 114 ++++++++++++++++++--------- 2 files changed, 81 insertions(+), 43 deletions(-) diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index 2dc793f078..c341545956 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/extra/terrain/shaders/shaders.factor @@ -4,15 +4,14 @@ IN: terrain.shaders STRING: terrain-vertex-shader uniform sampler2D heightmap; +uniform vec4 component_scale; varying vec2 heightcoords; -const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0); - float height(sampler2D map, vec2 coords) { vec4 v = texture2D(map, coords); - return dot(v, COMPONENT_SCALE); + return dot(v, component_scale); } void main() @@ -27,15 +26,14 @@ void main() STRING: terrain-pixel-shader uniform sampler2D heightmap; +uniform vec4 component_scale; varying vec2 heightcoords; -const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0); - float height(sampler2D map, vec2 coords) { vec4 v = texture2D(map, coords); - return dot(v, COMPONENT_SCALE); + return dot(v, component_scale); } void main() diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 6617275784..c6dce2d9c2 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -1,6 +1,6 @@ USING: accessors arrays combinators game-input -game-input.scancodes game-loop kernel literals locals math -math.constants math.functions math.matrices math.order +game-input.scancodes game-loop grouping kernel literals locals +math math.constants math.functions math.matrices math.order math.vectors opengl opengl.capabilities opengl.gl opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float @@ -9,19 +9,27 @@ ui.gadgets.worlds ui.pixel-formats ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] -CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ] -CONSTANT: FAR-PLANE 2.0 -CONSTANT: EYE-START { 0.5 0.5 1.2 } +CONSTANT: NEAR-PLANE $[ 1.0 2048.0 / ] +CONSTANT: FAR-PLANE 1.0 +CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 } +CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ] +CONSTANT: GRAVITY $[ 1.0 4096.0 / ] +CONSTANT: JUMP $[ 1.0 1024.0 / ] CONSTANT: TICK-LENGTH $[ 1000 30 /i ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] -CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ] +CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ] +CONSTANT: FRICTION 0.95 +CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.002 0.0 } CONSTANT: terrain-vertex-size { 512 512 } CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] +TUPLE: player + location yaw pitch velocity ; + TUPLE: terrain-world < world - eye yaw pitch + player terrain terrain-segment terrain-texture terrain-program terrain-vertex-buffer game-loop ; @@ -35,9 +43,10 @@ TUPLE: terrain-world < world GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear GL_MODELVIEW glMatrixMode glLoadIdentity + player>> [ pitch>> 1.0 0.0 0.0 glRotatef ] [ yaw>> 0.0 1.0 0.0 glRotatef ] - [ eye>> vneg first3 glTranslatef ] tri ; + [ location>> vneg first3 glTranslatef ] tri ; : vertex-array-vertex ( x z -- vertex ) [ terrain-vertex-distance first * ] @@ -79,47 +88,77 @@ TUPLE: terrain-world < world p cos :> cosp p sin :> sinp - cosy 0.0 siny neg 3array - siny sinp * cosp cosy sinp * 3array - siny cosp * sinp neg cosy cosp * 3array 3array + cosy 0.0 siny neg 3array + siny sinp * cosp cosy sinp * 3array + siny cosp * sinp neg cosy cosp * 3array 3array v swap v.m ; -: forward-vector ( world -- v ) - [ yaw>> ] [ pitch>> ] bi +: forward-vector ( player -- v ) + yaw>> 0.0 { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ; -: rightward-vector ( world -- v ) - [ yaw>> ] [ pitch>> ] bi +: rightward-vector ( player -- v ) + yaw>> 0.0 { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ; -: move-forward ( world -- ) - dup forward-vector [ v+ ] curry change-eye drop ; -: move-backward ( world -- ) - dup forward-vector [ v- ] curry change-eye drop ; -: move-leftward ( world -- ) - dup rightward-vector [ v- ] curry change-eye drop ; -: move-rightward ( world -- ) - dup rightward-vector [ v+ ] curry change-eye drop ; +: walk-forward ( player -- ) + dup forward-vector [ v+ ] curry change-velocity drop ; +: walk-backward ( player -- ) + dup forward-vector [ v- ] curry change-velocity drop ; +: walk-leftward ( player -- ) + dup rightward-vector [ v- ] curry change-velocity drop ; +: walk-rightward ( player -- ) + dup rightward-vector [ v+ ] curry change-velocity drop ; +: jump ( player -- ) + [ { 0.0 $ JUMP 0.0 } v+ ] change-velocity drop ; -: rotate-with-mouse ( world mouse -- ) +: clamp-pitch ( pitch -- pitch' ) + 90.0 min -90.0 max ; + +: rotate-with-mouse ( player mouse -- ) [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ] - [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi + [ dy>> MOUSE-SCALE * [ + clamp-pitch ] curry change-pitch ] bi drop ; :: handle-input ( world -- ) + world player>> :> player read-keyboard keys>> :> keys - key-w keys nth [ world move-forward ] when - key-s keys nth [ world move-backward ] when - key-a keys nth [ world move-leftward ] when - key-d keys nth [ world move-rightward ] when + key-w keys nth [ player walk-forward ] when + key-s keys nth [ player walk-backward ] when + key-a keys nth [ player walk-leftward ] when + key-d keys nth [ player walk-rightward ] when + key-space keys nth [ player jump ] when key-escape keys nth [ world close-window ] when - world read-mouse rotate-with-mouse + player read-mouse rotate-with-mouse reset-mouse ; -M: terrain-world tick* - [ handle-input ] keep - ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug +: apply-friction ( velocity -- velocity' ) + FRICTION v*n ; + +: apply-gravity ( velocity -- velocity' ) + 1 over [ GRAVITY - ] change-nth ; + +: pixel ( coords dim -- index ) + [ drop first ] [ [ second ] [ first ] bi* * ] 2bi + ; + +: terrain-height-at ( segment point -- height ) + over dim>> [ v* vfloor ] [ pixel >integer ] bi + swap bitmap>> 4 nth COMPONENT-SCALE v. 255.0 / ; + +: collide ( segment location -- location' ) + [ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ] + [ [ 1 ] 2dip [ max ] with change-nth ] + [ ] tri ; + +: tick-player ( world player -- ) + [ apply-friction apply-gravity ] change-velocity + dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location + P drop ; +M: terrain-world tick* + [ dup focused?>> [ handle-input ] [ drop ] if ] + [ dup player>> tick-player ] bi ; + M: terrain-world draw* nip draw-world ; @@ -137,9 +176,7 @@ M: terrain-world begin-world GL_TEXTURE_2D glEnable GL_VERTEX_ARRAY glEnableClientState 0.5 0.5 0.5 1.0 glClearColor - EYE-START >>eye - 0.0 >>yaw - 0.0 >>pitch + PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player [ >>terrain ] keep { 0 0 } terrain-segment [ >>terrain-segment ] keep make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture @@ -169,7 +206,8 @@ M: terrain-world draw-world* [ set-modelview-matrix ] [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ] [ dup terrain-program>> [ - "heightmap" glGetUniformLocation 0 glUniform1i + [ "heightmap" glGetUniformLocation 0 glUniform1i ] + [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi terrain-vertex-buffer>> draw-vertex-buffer ] with-gl-program ] tri gl-error ; @@ -190,3 +228,5 @@ M: terrain-world pref-dim* drop { 640 480 } ; { grab-input? t } } open-window ] with-ui ; + +MAIN: terrain-window From b0d7e38b2fa390d30b8fcb82e57fe47c1e63ce90 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 11:36:24 -0500 Subject: [PATCH 79/89] bilerp collision height --- extra/terrain/terrain.factor | 24 ++++++++++++++++++------ 1 file changed, 18 insertions(+), 6 deletions(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index c6dce2d9c2..083b162c01 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -137,12 +137,25 @@ TUPLE: terrain-world < world : apply-gravity ( velocity -- velocity' ) 1 over [ GRAVITY - ] change-nth ; -: pixel ( coords dim -- index ) - [ drop first ] [ [ second ] [ first ] bi* * ] 2bi + ; +:: pixel-indices ( coords dim -- indices ) + coords vfloor [ >integer ] map :> floor-coords + floor-coords first2 dim first * + :> base-index + base-index dim first + :> next-row-index -: terrain-height-at ( segment point -- height ) - over dim>> [ v* vfloor ] [ pixel >integer ] bi - swap bitmap>> 4 nth COMPONENT-SCALE v. 255.0 / ; + base-index + base-index 1 + + next-row-index + next-row-index 1 + 4array ; + +:: terrain-height-at ( segment point -- height ) + segment dim>> :> dim + dim point v* :> pixel + pixel dup vfloor v- :> pixel-mantissa + segment bitmap>> 4 :> pixels + pixel dim pixel-indices :> indices + + indices [ pixels nth COMPONENT-SCALE v. 255.0 / ] map + first4 [ pixel-mantissa first lerp ] 2bi@ pixel-mantissa second lerp ; : collide ( segment location -- location' ) [ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ] @@ -152,7 +165,6 @@ TUPLE: terrain-world < world : tick-player ( world player -- ) [ apply-friction apply-gravity ] change-velocity dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location - P drop ; M: terrain-world tick* From dd9af334a988a92eb9b11a419e0db1a768fede7d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 11:43:04 -0500 Subject: [PATCH 80/89] send bilerp upstream to spawn --- basis/math/vectors/vectors-tests.factor | 2 ++ basis/math/vectors/vectors.factor | 4 ++++ extra/terrain/terrain.factor | 2 +- 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index b4b12d619b..968af6a3aa 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -14,3 +14,5 @@ USING: math.vectors tools.test ; [ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test [ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test + +[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index eb203a5f12..17f6c39f04 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -41,6 +41,10 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: bilerp ( aa ba ab bb {t,u} -- a_tu ) + [ first lerp ] [ second lerp ] bi-curry + [ 2bi@ ] [ call ] bi* ; + : vlerp ( a b t -- a_t ) [ lerp ] 3map ; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 083b162c01..d58aa4ec30 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -155,7 +155,7 @@ TUPLE: terrain-world < world pixel dim pixel-indices :> indices indices [ pixels nth COMPONENT-SCALE v. 255.0 / ] map - first4 [ pixel-mantissa first lerp ] 2bi@ pixel-mantissa second lerp ; + first4 pixel-mantissa bilerp ; : collide ( segment location -- location' ) [ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ] From 84c7f10ab7dbc5e0d3d901b848ef018ddb39a86d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 12:53:01 -0500 Subject: [PATCH 81/89] factor game-input and game-loop mgmt out to a game-world base object --- extra/game-worlds/game-worlds.factor | 24 ++++++++++++++++++++++++ extra/terrain/terrain.factor | 27 ++++++++++----------------- 2 files changed, 34 insertions(+), 17 deletions(-) create mode 100644 extra/game-worlds/game-worlds.factor diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor new file mode 100644 index 0000000000..864bd28fc1 --- /dev/null +++ b/extra/game-worlds/game-worlds.factor @@ -0,0 +1,24 @@ +USING: accessors game-input game-loop kernel ui.gadgets +ui.gadgets.worlds ui.gestures ; +IN: game-worlds + +TUPLE: game-world < world + game-loop ; + +GENERIC: tick-length ( world -- millis ) + +M: game-world draw* + nip draw-world ; + +M: game-world begin-world + dup [ tick-length ] [ ] bi [ >>game-loop ] keep start-loop + drop + open-game-input ; + +M: game-world end-world + close-game-input + [ [ stop-loop ] when* f ] change-game-loop + drop ; + +M: game-world focusable-child* drop t ; + diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index d58aa4ec30..fe105b2e52 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -1,11 +1,11 @@ -USING: accessors arrays combinators game-input -game-input.scancodes game-loop grouping kernel literals locals +USING: accessors arrays combinators game-input game-loop +game-input.scancodes grouping kernel literals locals math math.constants math.functions math.matrices math.order math.vectors opengl opengl.capabilities opengl.gl opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float terrain.generation terrain.shaders ui ui.gadgets -ui.gadgets.worlds ui.pixel-formats ; +ui.gadgets.worlds ui.pixel-formats game-worlds method-chains ; IN: terrain CONSTANT: FOV $[ 2.0 sqrt 1+ ] @@ -15,7 +15,6 @@ CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 } CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ] CONSTANT: GRAVITY $[ 1.0 4096.0 / ] CONSTANT: JUMP $[ 1.0 1024.0 / ] -CONSTANT: TICK-LENGTH $[ 1000 30 /i ] CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ] CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ] CONSTANT: FRICTION 0.95 @@ -28,11 +27,13 @@ CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] TUPLE: player location yaw pitch velocity ; -TUPLE: terrain-world < world +TUPLE: terrain-world < game-world player terrain terrain-segment terrain-texture terrain-program - terrain-vertex-buffer - game-loop ; + terrain-vertex-buffer ; + +M: terrain-world tick-length + drop 1000 30 /i ; : frustum ( dim -- -x x -y y near far ) dup first2 min v/n @@ -171,9 +172,6 @@ M: terrain-world tick* [ dup focused?>> [ handle-input ] [ drop ] if ] [ dup player>> tick-player ] bi ; -M: terrain-world draw* - nip draw-world ; - : set-heightmap-texture-parameters ( texture -- ) GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri @@ -181,7 +179,7 @@ M: terrain-world draw* GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ; -M: terrain-world begin-world +BEFORE: terrain-world begin-world "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" } require-gl-version-or-extensions GL_DEPTH_TEST glEnable @@ -195,14 +193,10 @@ M: terrain-world begin-world terrain-vertex-shader terrain-pixel-shader >>terrain-program vertex-array >vertex-buffer >>terrain-vertex-buffer - TICK-LENGTH over [ >>game-loop ] keep start-loop - open-game-input drop ; -M: terrain-world end-world - close-game-input +AFTER: terrain-world end-world { - [ game-loop>> stop-loop ] [ terrain-vertex-buffer>> delete-gl-buffer ] [ terrain-program>> delete-gl-program ] [ terrain-texture>> delete-texture ] @@ -224,7 +218,6 @@ M: terrain-world draw-world* ] with-gl-program ] tri gl-error ; -M: terrain-world focusable-child* drop t ; M: terrain-world pref-dim* drop { 640 480 } ; : terrain-window ( -- ) From 4367068ba60d2899f062a03c96f1bf8723863d31 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 14:31:33 -0500 Subject: [PATCH 82/89] save off the tick-slice when draw*-ing a game-world --- extra/game-worlds/game-worlds.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor index 864bd28fc1..fa6b326fa9 100644 --- a/extra/game-worlds/game-worlds.factor +++ b/extra/game-worlds/game-worlds.factor @@ -1,14 +1,15 @@ -USING: accessors game-input game-loop kernel ui.gadgets +USING: accessors game-input game-loop kernel math ui.gadgets ui.gadgets.worlds ui.gestures ; IN: game-worlds TUPLE: game-world < world - game-loop ; + game-loop + { tick-slice float initial: 0.0 } ; GENERIC: tick-length ( world -- millis ) M: game-world draw* - nip draw-world ; + swap >>tick-slice draw-world ; M: game-world begin-world dup [ tick-length ] [ ] bi [ >>game-loop ] keep start-loop From 8cbcb87152cef62bd8719f0f4f41f424de88fc4c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 14:33:17 -0500 Subject: [PATCH 83/89] don't mess with the orphaned nodes when pop-front-ing or pop-back-ing a dlist. add a dlist-filter word that drops off all nodes that don't satisfy a predicate --- basis/dlists/dlists-tests.factor | 5 +++++ basis/dlists/dlists.factor | 7 +++++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor index 3689680157..8072c93753 100755 --- a/basis/dlists/dlists-tests.factor +++ b/basis/dlists/dlists-tests.factor @@ -79,3 +79,8 @@ IN: dlists.tests [ V{ f 3 1 f } ] [ 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test [ V{ } ] [ dlist>seq ] unit-test + +[ V{ 0 2 4 } ] [ { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 2 4 } ] [ { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 2 4 } ] [ { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test +[ V{ 0 2 4 } ] [ { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor index 3d7224ed16..89675c6469 100755 --- a/basis/dlists/dlists.factor +++ b/basis/dlists/dlists.factor @@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- ) [ [ [ empty-dlist ] unless* - [ f ] change-next drop + next>> f over set-prev-when ] change-front drop ] keep @@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- ) [ [ [ empty-dlist ] unless* - [ f ] change-prev drop + prev>> f over set-next-when ] change-back drop ] keep @@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- ) : 1dlist ( obj -- dlist ) [ push-front ] keep ; +: dlist-filter ( dlist quot -- dlist ) + over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline + M: dlist clone [ '[ _ push-back ] dlist-each ] keep ; From 4ee4357e75f1af23950e0eb4622c83d5b2cb8ae5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 May 2009 18:17:30 -0500 Subject: [PATCH 84/89] Fix negative zero smashing with bootstrap --- basis/bootstrap/image/image.factor | 3 +++ core/math/math.factor | 2 ++ 2 files changed, 5 insertions(+) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 55e6a31491..92d75604e0 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? ) M: integer (eql?) = ; +M: float (eql?) + over float? [ fp-bitwise= ] [ 2drop f ] if ; + M: sequence (eql?) over sequence? [ 2dup [ length ] bi@ = diff --git a/core/math/math.factor b/core/math/math.factor index 6a087ec909..da9bc4d1b5 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -81,6 +81,8 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ; UNION: number real complex ; +: fp-bitwise= ( x y -- ? ) [ double>bits ] bi@ = ; inline + GENERIC: fp-special? ( x -- ? ) GENERIC: fp-nan? ( x -- ? ) GENERIC: fp-qnan? ( x -- ? ) From cbb1f1c60b3f224cf8c9e9913818b5afeee4a596 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 20:15:03 -0500 Subject: [PATCH 85/89] docs for dlist-filter --- basis/dlists/dlists-docs.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor index 12e39746c7..e210ad35ce 100755 --- a/basis/dlists/dlists-docs.factor +++ b/basis/dlists/dlists-docs.factor @@ -15,6 +15,7 @@ $nl "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } +{ $subsection dlist-filter } { $subsection dlist-any? } "Deleting a node matching a predicate:" { $subsection delete-node-if* } @@ -40,6 +41,11 @@ HELP: dlist-find "This operation is O(n)." } ; +HELP: dlist-filter +{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } } +{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." } +{ $side-effects { "dlist" } } ; + HELP: dlist-any? { $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } } { $description "Just like " { $link dlist-find } " except it doesn't return the object." } From e4059d8393c81efe4ff7ebdb01e630d492ffbe19 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 20:15:55 -0500 Subject: [PATCH 86/89] clamp coordinates when doing terrain collision detection past the edge of the segment --- extra/terrain/terrain.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index fe105b2e52..590244ca6a 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -138,8 +138,11 @@ M: terrain-world tick-length : apply-gravity ( velocity -- velocity' ) 1 over [ GRAVITY - ] change-nth ; +: clamp-coords ( coords dim -- coords' ) + [ { 0 0 } vmax ] dip { 2 2 } v- vmin ; + :: pixel-indices ( coords dim -- indices ) - coords vfloor [ >integer ] map :> floor-coords + coords vfloor [ >integer ] map dim clamp-coords :> floor-coords floor-coords first2 dim first * + :> base-index base-index dim first + :> next-row-index From 7584b3075593b95689df75c2d69ebec261157db6 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 9 May 2009 20:23:56 -0500 Subject: [PATCH 87/89] "math" help-lint --- core/math/math-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 75370d6cfd..e5f68a511c 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -274,7 +274,7 @@ HELP: fp-nan-payload { $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ; HELP: -{ $values { "payload" integer } { "float" float } } +{ $values { "payload" integer } { "nan" float } } { $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." } { $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ; From cda3685c4dcd632b4b73412a6d36f22192a75f1e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 May 2009 20:24:17 -0500 Subject: [PATCH 88/89] Eliminate prettyprinter dependency from UI --- basis/math/rectangles/prettyprint/authors.txt | 1 + basis/math/rectangles/prettyprint/prettyprint.factor | 7 +++++++ basis/math/rectangles/rectangles.factor | 9 +++++---- basis/ui/gadgets/gadgets.factor | 10 +++++----- basis/ui/gadgets/prettyprint/authors.txt | 1 + basis/ui/gadgets/prettyprint/prettyprint.factor | 7 +++++++ 6 files changed, 26 insertions(+), 9 deletions(-) create mode 100644 basis/math/rectangles/prettyprint/authors.txt create mode 100644 basis/math/rectangles/prettyprint/prettyprint.factor create mode 100644 basis/ui/gadgets/prettyprint/authors.txt create mode 100644 basis/ui/gadgets/prettyprint/prettyprint.factor diff --git a/basis/math/rectangles/prettyprint/authors.txt b/basis/math/rectangles/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/math/rectangles/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/math/rectangles/prettyprint/prettyprint.factor b/basis/math/rectangles/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..c23be50029 --- /dev/null +++ b/basis/math/rectangles/prettyprint/prettyprint.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ; +IN: math.rectangles.prettyprint + +M: rect pprint* + \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor index 340eafa37d..c8569dfdb9 100644 --- a/basis/math/rectangles/rectangles.factor +++ b/basis/math/rectangles/rectangles.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays sequences math math.vectors accessors -parser prettyprint.custom prettyprint.backend ; +parser ; IN: math.rectangles TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; @@ -10,9 +10,6 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ; SYNTAX: RECT: scan-object scan-object parsed ; -M: rect pprint* - \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ; - : ( -- rect ) rect new ; inline : point>rect ( loc -- rect ) { 0 0 } ; inline @@ -64,3 +61,7 @@ M: rect contains-point? [ [ loc>> ] dip (>>loc) ] [ [ dim>> ] dip (>>dim) ] 2bi ; inline + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when \ No newline at end of file diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index f9f397d46f..5dd1710cdd 100644 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -3,8 +3,7 @@ USING: accessors arrays hashtables kernel models math namespaces make sequences quotations math.vectors combinators sorting binary-search vectors dlists deques models threads -concurrency.flags math.order math.rectangles fry locals -prettyprint.backend prettyprint.custom ; +concurrency.flags math.order math.rectangles fry locals ; IN: ui.gadgets ! Values for orientation slot @@ -28,9 +27,6 @@ interior boundary model ; -! Don't print gadgets with RECT: syntax -M: gadget pprint* pprint-tuple ; - M: gadget equal? 2drop f ; M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ; @@ -397,3 +393,7 @@ M: f request-focus-on 2drop ; : focus-path ( gadget -- seq ) [ focus>> ] follow ; + +USING: vocabs vocabs.loader ; + +"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when \ No newline at end of file diff --git a/basis/ui/gadgets/prettyprint/authors.txt b/basis/ui/gadgets/prettyprint/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/ui/gadgets/prettyprint/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/ui/gadgets/prettyprint/prettyprint.factor b/basis/ui/gadgets/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..82a89eda11 --- /dev/null +++ b/basis/ui/gadgets/prettyprint/prettyprint.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: ui.gadgets prettyprint.backend prettyprint.custom ; +IN: ui.gadgets.prettyprint + +! Don't print gadgets with RECT: syntax +M: gadget pprint* pprint-tuple ; \ No newline at end of file From aa3aa715beac977f8f207e5d090f7b0a03780a0b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 May 2009 20:24:32 -0500 Subject: [PATCH 89/89] Slightly more space-efficient dispatch table representation --- core/generic/single/single.factor | 2 +- vm/dispatch.cpp | 11 +++++------ 2 files changed, 6 insertions(+), 7 deletions(-) diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 36a76153f9..8d84b21bf7 100644 --- a/core/generic/single/single.factor +++ b/core/generic/single/single.factor @@ -163,7 +163,7 @@ M: hi-tag-dispatch-engine compile-engine : build-fast-hash ( methods -- buckets ) >alist V{ } clone [ hashcode 1array ] distribute-buckets - [ compile-engines* >alist >array ] map ; + [ compile-engines* >alist { } join ] map ; M: echelon-dispatch-engine compile-engine dup n>> 0 = [ diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp index 847a19d738..4a1411733e 100755 --- a/vm/dispatch.cpp +++ b/vm/dispatch.cpp @@ -8,15 +8,14 @@ cell megamorphic_cache_misses; static cell search_lookup_alist(cell table, cell klass) { - array *pairs = untag(table); - fixnum index = array_capacity(pairs) - 1; + array *elements = untag(table); + fixnum index = array_capacity(elements) - 2; while(index >= 0) { - array *pair = untag(array_nth(pairs,index)); - if(array_nth(pair,0) == klass) - return array_nth(pair,1); + if(array_nth(elements,index) == klass) + return array_nth(elements,index + 1); else - index--; + index -= 2; } return F;