From 7ba28ac8d5c45a638cd8027097e476e99c998d98 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 02:37:16 -0500
Subject: [PATCH 1/9] Clean up raytracer a bit
---
extra/benchmark/raytracer/raytracer.factor | 60 +++++++++++-----------
1 file changed, 31 insertions(+), 29 deletions(-)
diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor
index 69454505a5..34bac61292 100755
--- a/extra/benchmark/raytracer/raytracer.factor
+++ b/extra/benchmark/raytracer/raytracer.factor
@@ -3,7 +3,7 @@
USING: arrays accessors float-arrays io io.files
io.encodings.binary kernel math math.functions math.vectors
-math.parser make sequences sequences.private words ;
+math.parser make sequences sequences.private words hints ;
IN: benchmark.raytracer
! parameters
@@ -38,34 +38,40 @@ TUPLE: sphere { center float-array read-only } { radius float read-only } ;
C: <sphere> sphere
: sphere-v ( sphere ray -- v )
- swap center>> swap orig>> v- ; inline
+ [ center>> ] [ orig>> ] bi* v- ; inline
-: sphere-b ( ray v -- b ) swap dir>> v. ; inline
+: sphere-b ( v ray -- b )
+ dir>> v. ; inline
-: sphere-disc ( sphere v b -- d )
- sq swap norm-sq - swap radius>> sq + ; inline
+: sphere-d ( sphere b v -- d )
+ [ radius>> sq ] [ sq ] [ norm-sq ] tri* - + ; inline
-: -+ ( x y -- x-y x+y ) [ - ] 2keep + ; inline
+: -+ ( x y -- x-y x+y )
+ [ - ] [ + ] 2bi ; inline
-: sphere-b/d ( b d -- t )
+: sphere-t ( b d -- t )
-+ dup 0.0 <
[ 2drop 1.0/0.0 ] [ [ [ 0.0 > ] keep ] dip ? ] if ; inline
-: ray-sphere ( sphere ray -- t )
- 2dup sphere-v tuck sphere-b [ sphere-disc ] keep
- over 0.0 < [ 2drop 1.0/0.0 ] [ swap sqrt sphere-b/d ] if ;
- inline
+: sphere-b&v ( sphere ray -- b v )
+ [ sphere-v ] [ nip ] 2bi
+ [ sphere-b ] [ drop ] 2bi ; inline
-: sphere-n ( ray sphere l -- n )
- pick dir>> n*v swap center>> v- swap orig>> v+ ;
- inline
+: ray-sphere ( sphere ray -- t )
+ [ drop ] [ sphere-b&v ] 2bi
+ [ drop ] [ sphere-d ] 3bi
+ dup 0.0 < [ 3drop 1/0. ] [ sqrt sphere-t nip ] if ; inline
: if-ray-sphere ( hit ray sphere quot -- hit )
#! quot: hit ray sphere l -- hit
[
- pick lambda>> [ 2dup swap ray-sphere dup ] dip >=
- [ 3drop ]
- ] dip if ; inline
+ [ ] [ swap ray-sphere nip ] [ 2drop lambda>> ] 3tri
+ [ drop ] [ < ] 2bi
+ ] dip [ 3drop ] if ; inline
+
+: sphere-n ( ray sphere l -- n )
+ [ [ orig>> ] [ dir>> ] bi ] [ center>> ] [ ] tri*
+ swap [ v*n ] dip v- v+ ; inline
M: sphere intersect-scene ( hit ray sphere -- hit )
[ [ sphere-n normalize ] keep <hit> nip ] if-ray-sphere ;
@@ -79,21 +85,17 @@ TUPLE: group < sphere { objs array read-only } ;
swap [ { } make ] dip <group> ; inline
M: group intersect-scene ( hit ray group -- hit )
- [
- drop
- objs>> [ [ tuck ] dip intersect-scene swap ] each
- drop
- ] if-ray-sphere ;
+ [ drop objs>> [ intersect-scene ] with each ] if-ray-sphere ;
-: initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1.0/0.0 } ; inline
+: initial-hit T{ hit f F{ 0.0 0.0 0.0 } 1/0. } ; inline
: initial-intersect ( ray scene -- hit )
- initial-hit -rot intersect-scene ; inline
+ [ initial-hit ] 2dip intersect-scene ; inline
: ray-o ( ray hit -- o )
- over dir>> over lambda>> v*n
- swap normal>> delta v*n v+
- swap orig>> v+ ; inline
+ [ [ orig>> ] [ normal>> delta v*n ] bi* ]
+ [ [ dir>> ] [ lambda>> ] bi* v*n ]
+ 2bi v+ v+ ; inline
: sray-intersect ( ray scene hit -- ray )
swap [ ray-o light vneg <ray> ] dip initial-intersect ; inline
@@ -101,10 +103,10 @@ M: group intersect-scene ( hit ray group -- hit )
: ray-g ( hit -- g ) normal>> light v. ; inline
: cast-ray ( ray scene -- g )
- 2dup initial-intersect dup lambda>> 1.0/0.0 = [
+ 2dup initial-intersect dup lambda>> 1/0. = [
3drop 0.0
] [
- [ sray-intersect lambda>> 1.0/0.0 = ] keep swap
+ [ sray-intersect lambda>> 1/0. = ] keep swap
[ ray-g neg ] [ drop 0.0 ] if
] if ; inline
From 2cc40052bfeffb82a31f76a005ace9c6e3e6249d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 03:06:36 -0500
Subject: [PATCH 2/9] Rewrite locals-in-literals in idiomatic Factor, and fix a
performance regression with locals in tuples
---
basis/locals/locals-tests.factor | 4 +-
basis/locals/locals.factor | 93 +++++++++++---------------------
2 files changed, 35 insertions(+), 62 deletions(-)
diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor
index 59ec325f39..eb06d05146 100755
--- a/basis/locals/locals-tests.factor
+++ b/basis/locals/locals-tests.factor
@@ -329,4 +329,6 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
[ 10 20 30 [| a b c | H{ { a "a" } { b "b" } { c "c" } } ] call ] unit-test
[ T{ slice f 0 3 "abc" } ]
-[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
\ No newline at end of file
+[ 0 3 "abc" [| from to seq | T{ slice f from to seq } ] call ] unit-test
+
+{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
\ No newline at end of file
diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index bfc92ee9e2..05ea3cb524 100755
--- a/basis/locals/locals.factor
+++ b/basis/locals/locals.factor
@@ -6,7 +6,7 @@ quotations debugger macros arrays macros splitting combinators
prettyprint.backend definitions prettyprint hashtables
prettyprint.sections sets sequences.private effects
effects.parser generic generic.parser compiler.units accessors
-locals.backend memoize macros.expander lexer
+locals.backend memoize macros.expander lexer classes
stack-checker.known-words ;
IN: locals
@@ -195,70 +195,41 @@ M: block lambda-rewrite*
swap point-free ,
] keep length \ curry <repetition> % ;
+GENERIC: rewrite-element ( obj -- )
+
+: rewrite-elements ( seq -- )
+ [ rewrite-element ] each ;
+
+: rewrite-sequence ( seq -- )
+ [ rewrite-elements ] [ length , ] [ , ] tri \ nsequence , ;
+
+M: array rewrite-element rewrite-sequence ;
+
+M: vector rewrite-element rewrite-sequence ;
+
+M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
+
+M: tuple rewrite-element
+ [ tuple-slots rewrite-elements ] [ class , ] bi \ boa , ;
+
+M: local rewrite-element , ;
+
+M: word rewrite-element literalize , ;
+
+M: object rewrite-element , ;
+
+M: array local-rewrite* rewrite-element ;
+
+M: vector local-rewrite* rewrite-element ;
+
+M: tuple local-rewrite* rewrite-element ;
+
+M: hashtable local-rewrite* rewrite-element ;
+
M: object lambda-rewrite* , ;
M: object local-rewrite* , ;
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-! Broil is used to support locals in literals
-
-DEFER: [broil]
-DEFER: [broil-hashtable]
-DEFER: [broil-tuple]
-
-: broil-element ( obj -- quot )
- {
- { [ dup number? ] [ 1quotation ] }
- { [ dup string? ] [ 1quotation ] }
- { [ dup sequence? ] [ [broil] ] }
- { [ dup hashtable? ] [ [broil-hashtable] ] }
- { [ dup tuple? ] [ [broil-tuple] ] }
- { [ dup local? ] [ 1quotation ] }
- { [ dup word? ] [ literalize 1quotation ] }
- { [ t ] [ 1quotation ] }
- }
- cond ;
-
-: [broil] ( seq -- quot )
- [ [ broil-element ] map concat >quotation ]
- [ length ]
- [ ]
- tri
- [ nsequence ] curry curry compose ;
-
-MACRO: broil ( seq -- quot ) [broil] ;
-
-: [broil-hashtable] ( hashtable -- quot )
- >alist
- [ [ broil-element ] map concat >quotation ]
- [ length ]
- [ ]
- tri
- [ nsequence >hashtable ] curry curry compose ;
-
-MACRO: broil-hashtable ( hashtable -- quot ) [broil-hashtable] ;
-
-: [broil-tuple] ( tuple -- quot )
- tuple>array
- [ [ broil-element ] map concat >quotation ]
- [ length ]
- [ ]
- tri
- [ nsequence >tuple ] curry curry compose ;
-
-MACRO: broil-tuple ( tuple -- quot ) [broil-tuple] ;
-
-! Engage broil on arrays and vectors. Can't do it on 'sequence'
-! because that will pick up strings and integers. What do do...
-
-M: array local-rewrite* ( array -- ) [broil] % ;
-M: vector local-rewrite* ( vector -- ) [broil] % ;
-M: tuple local-rewrite* ( tuple -- ) [broil-tuple] % ;
-M: hashtable local-rewrite* ( hashtable -- ) [broil-hashtable] % ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
: make-local ( name -- word )
"!" ?tail [
<local-reader>
From 01129fb9bd9ad598bc2889125edb7d2ff681f230 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 03:09:16 -0500
Subject: [PATCH 3/9] Add unit test for locals performance regresion
---
basis/compiler/tree/propagation/propagation-tests.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index 6638951723..d73e8b7db1 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -7,7 +7,8 @@ byte-arrays classes.algebra classes.tuple.private
math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker
-slots.private words hashtables classes assocs ;
+slots.private words hashtables classes assocs locals
+float-arrays ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@@ -587,6 +588,8 @@ MIXIN: empty-mixin
[ { fixnum integer } declare bitand ] final-classes
] unit-test
+[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
From 87797847987eb8c2252e2b3dc3956e78125fd970 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 03:12:52 -0500
Subject: [PATCH 4/9] Support hints on methods
---
basis/hints/hints-docs.factor | 21 ++++++++++++++++++---
basis/hints/hints.factor | 5 +++--
2 files changed, 21 insertions(+), 5 deletions(-)
diff --git a/basis/hints/hints-docs.factor b/basis/hints/hints-docs.factor
index 99c4a2ddfc..347cfd3ef4 100644
--- a/basis/hints/hints-docs.factor
+++ b/basis/hints/hints-docs.factor
@@ -20,9 +20,24 @@ HELP: specialized-def
{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
HELP: HINTS:
-{ $values { "word" word } { "hints..." "a list of sequences of classes" } }
-{ $description "Defines specialization hints for each words. Each sequence of classes in the list will cause a specialized version of the word to be compiled." }
+{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes" } }
+{ $description "Defines specialization hints for a word or a method."
+$nl
+"Each sequence of classes in the list will cause a specialized version of the word to be compiled." }
{ $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
-{ $code "HINTS: append { string string } { array array } ;" } } ;
+{ $code "HINTS: append { string string } { array array } ;" }
+"Specializers can also be defined on methods:"
+{ $code
+ "GENERIC: count-occurrences ( elt obj -- n )"
+ ""
+ "M: sequence count-occurrences [ = ] with count ;"
+ ""
+ "M: assoc count-occurrences"
+ " swap [ = nip ] curry assoc-filter assoc-size ;"
+ ""
+ "HINTS: { sequence count-occurrences } { object array } ;"
+ "HINTS: { assoc count-occurrences } { object hashtable } ;"
+}
+} ;
ABOUT: "hints"
diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index 1138ad872a..a10588d730 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -42,11 +42,11 @@ IN: hints
: specialized-def ( word -- quot )
dup def>> swap {
- { [ dup standard-method? ] [ specialize-method ] }
{
[ dup "specializer" word-prop ]
[ "specializer" word-prop specialize-quot ]
}
+ { [ dup standard-method? ] [ specialize-method ] }
[ drop ]
} cond ;
@@ -54,7 +54,8 @@ IN: hints
dup [ array? ] all? [ first ] when length ;
: HINTS:
- scan-word
+ scan-object
+ dup method-spec? [ first2 method ] when
[ redefined ]
[ parse-definition "specializer" set-word-prop ] bi ;
parsing
From d2646cfe1bc7cba51179131d17adc399c47e6462 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 13 Sep 2008 04:09:13 -0500
Subject: [PATCH 5/9] tools.annotations: Use fry in '(watch)'
---
basis/tools/annotations/annotations.factor | 7 ++-----
1 file changed, 2 insertions(+), 5 deletions(-)
diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index 96c2ec2fcc..6a7e33e615 100755
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -3,7 +3,7 @@
USING: accessors kernel words parser io summary quotations
sequences prettyprint continuations effects definitions
compiler.units namespaces assocs tools.walker generic
-inspector ;
+inspector fry ;
IN: tools.annotations
GENERIC: reset ( word -- )
@@ -49,10 +49,7 @@ M: word reset
.s
] if* "\\--" print flush ;
-: (watch) ( word def -- def )
- over [ entering ] curry
- rot [ leaving ] curry
- swapd 3append ;
+: (watch) ( word def -- def ) over '[ _ entering @ _ leaving ] ;
: watch ( word -- )
dup [ (watch) ] annotate ;
From a211e44bb9264a9e345c132541c462251c6fb5ea Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 04:43:29 -0500
Subject: [PATCH 6/9] Found a place to use the locals in literals feature
---
basis/compiler/tree/dead-code/recursive/recursive.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/compiler/tree/dead-code/recursive/recursive.factor b/basis/compiler/tree/dead-code/recursive/recursive.factor
index 03d4e919ee..02dc42f058 100644
--- a/basis/compiler/tree/dead-code/recursive/recursive.factor
+++ b/basis/compiler/tree/dead-code/recursive/recursive.factor
@@ -84,7 +84,7 @@ M:: #recursive remove-dead-code* ( node -- nodes )
drop-outputs [ node drop-recursive-outputs ] |
node [ (remove-dead-code) ] change-child drop
node label>> [ filter-live ] change-enter-out drop
- drop-inputs node drop-outputs 3array
+ { drop-inputs node drop-outputs }
] ;
M: #return-recursive remove-dead-code* ;
From d47a76b69bc9881f74602d75baf6eb15e6f5eebc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 06:13:49 -0500
Subject: [PATCH 7/9] 15% improvement
---
extra/benchmark/spectral-norm/spectral-norm.factor | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor
index 3c20a1ceff..245027ef77 100644
--- a/extra/benchmark/spectral-norm/spectral-norm.factor
+++ b/extra/benchmark/spectral-norm/spectral-norm.factor
@@ -32,8 +32,10 @@ IN: benchmark.spectral-norm
: eval-AtA-times-u ( u n -- seq )
[ eval-A-times-u ] [ eval-At-times-u ] bi ; inline
+: ones ( n -- seq ) [ 1.0 ] F{ } replicate-as ; inline
+
:: u/v ( n -- u v )
- n 1.0 <repetition> >float-array dup
+ n ones dup
10 [
drop
n eval-AtA-times-u
From 1bf65e6dc5a91fd8bd2fa3ca22c5af53f5ea32f1 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 13 Sep 2008 11:12:36 -0500
Subject: [PATCH 8/9] tools.annotations: Use fry in '(watch-vars)'
---
basis/tools/annotations/annotations.factor | 11 ++++++-----
1 file changed, 6 insertions(+), 5 deletions(-)
diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor
index 6a7e33e615..c836bfc2b6 100755
--- a/basis/tools/annotations/annotations.factor
+++ b/basis/tools/annotations/annotations.factor
@@ -55,11 +55,12 @@ M: word reset
dup [ (watch) ] annotate ;
: (watch-vars) ( quot word vars -- newquot )
- [
- "--- Entering: " write swap .
- "--- Variable values:" print
- [ dup get ] H{ } map>assoc describe
- ] 2curry prepose ;
+ rot
+ '[
+ "--- Entering: " write _ .
+ "--- Variable values:" print _ [ dup get ] H{ } map>assoc describe
+ @
+ ] ;
: watch-vars ( word vars -- )
dupd [ (watch-vars) ] 2curry annotate ;
From 8b9784108e5d8b7d50fc0104ab745652b1cc1b37 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Sep 2008 14:25:06 -0500
Subject: [PATCH 9/9] Don't clobber RBX
---
basis/cpu/x86/32/32.factor | 4 ----
basis/cpu/x86/64/64.factor | 15 +++++----------
basis/cpu/x86/architecture/architecture.factor | 2 --
3 files changed, 5 insertions(+), 16 deletions(-)
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 67a8ec8a2c..5328f2a263 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -62,10 +62,6 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
: with-aligned-stack ( n quot -- )
swap dup align-sub slip align-add ; inline
-! On x86, we can always use an address as an operand
-! directly.
-M: x86.32 address-operand ;
-
M: x86.32 fixnum>slot@ 1 SHR ;
M: x86.32 prepare-division CDQ ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 4770c09a83..c135d0490d 100755
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -33,13 +33,6 @@ M: float-regs vregs
M: float-regs param-regs
drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
-M: x86.64 address-operand ( address -- operand )
- #! On AMD64, we have to load 64-bit addresses into a
- #! scratch register first. The usage of R11 here is a hack.
- #! This word can only be called right before a subroutine
- #! call, where all vregs have been flushed anyway.
- temp-reg v>operand [ swap MOV ] keep ;
-
M: x86.64 fixnum>slot@ drop ;
M: x86.64 prepare-division CQO ;
@@ -49,8 +42,8 @@ M: x86.64 load-indirect ( literal reg -- )
M: stack-params %load-param-reg
drop
- >r temp-reg v>operand swap stack@ MOV
- r> stack@ temp-reg v>operand MOV ;
+ >r R11 swap stack@ MOV
+ r> stack@ R11 MOV ;
M: stack-params %save-param-reg
>r stack-frame* + cell + swap r> %load-param-reg ;
@@ -138,7 +131,9 @@ M: x86.64 %alien-global
[ 0 MOV rc-absolute-cell rel-dlsym ] [ dup [] MOV ] bi ;
M: x86.64 %alien-invoke
- 0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
+ R11 0 MOV
+ rc-absolute-cell rel-dlsym
+ R11 CALL ;
M: x86.64 %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 171e67bcfb..04b496f12a 100755
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -39,8 +39,6 @@ GENERIC: store-return-reg ( stack@ reg-class -- )
HOOK: temp-reg-1 cpu ( -- reg )
HOOK: temp-reg-2 cpu ( -- reg )
-HOOK: address-operand cpu ( address -- operand )
-
HOOK: fixnum>slot@ cpu ( op -- )
HOOK: prepare-division cpu ( -- )