From 1fa0bfc130f767d8d34128ce488eb192efd8c9d1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 14 Aug 2005 05:17:25 +0000 Subject: [PATCH] arithmetic identities --- TODO.FACTOR.txt | 6 +-- library/compiler/compiler.factor | 3 ++ library/inference/call-optimizers.factor | 66 +++++++++++++++--------- library/test/benchmark/sort.factor | 10 +--- library/test/compiler/intrinsics.factor | 3 -- library/ui/splitters.factor | 4 +- 6 files changed, 49 insertions(+), 43 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 1d3ebda4aa..106a08195d 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -73,13 +73,9 @@ - recursion is iffy; no base case needs to throw an error, and if the stack at the recursive call doesn't match up, throw an error -+ sequences - -- array sort -- specialized arrays - + kernel: +- specialized arrays - clear "predicating" word prop when redefining words - there is a problem with hashcodes of words and bootstrapping - delegating generic words with a non-standard picker diff --git a/library/compiler/compiler.factor b/library/compiler/compiler.factor index cc34de9ae7..c9b8c799fa 100644 --- a/library/compiler/compiler.factor +++ b/library/compiler/compiler.factor @@ -60,3 +60,6 @@ M: compound (compile) ( word -- ) : recompile ( word -- ) dup decompile compile ; + +: compile-1 ( quot -- word ) + gensym [ swap define-compound ] keep dup compile execute ; diff --git a/library/inference/call-optimizers.factor b/library/inference/call-optimizers.factor index ba7ab5518b..d4b892f811 100644 --- a/library/inference/call-optimizers.factor +++ b/library/inference/call-optimizers.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inference -USING: errors hashtables kernel math math-internals sequences -vectors words ; +USING: errors generic hashtables kernel math math-internals +sequences vectors words ; ! A system for associating dataflow optimizers with words. @@ -48,15 +48,13 @@ vectors words ; { [ dup node-successor #ifte? ] [ node-successor dup flip-branches ] } } define-optimizers -M: #call optimize-node* ( node -- node/t ) - { - { [ dup node-param not ] [ node-successor ] } - { [ dup partial-eval? ] [ partial-eval ] } - { [ dup optimizer-hooks ] [ optimize-hooks ] } - { [ dup inlining-class ] [ inline-method ] } - { [ dup optimize-predicate? ] [ optimize-predicate ] } - { [ t ] [ drop t ] } - } cond ; +: disjoint-eq? ( node -- ? ) + dup node-classes swap node-in-d [ swap hash ] map-with + 2unseq class-and null = ; + +\ eq? { + { [ dup disjoint-eq? ] [ [ f ] inline-literals ] } +} define-optimizers ! Arithmetic identities SYMBOL: @ @@ -70,14 +68,21 @@ SYMBOL: @ ] 2map conjunction ; : values-match? ( values template -- ? ) - [ @ = ] 2map [ ] subset [ eq? ] every? ; + [ @ = [ drop f ] unless ] 2map [ ] subset [ eq? ] every? ; : apply-identity? ( values identity -- ? ) first 2dup literals-match? >r values-match? r> and ; -: apply-identities ( values identities -- node/f ) - dupd [ apply-identity? ] find-with nip dup - [ second swap dataflow-with ] [ 2drop f ] ifte ; +: find-identity ( node -- values identity ) + dup node-in-d swap node-param "identities" word-prop + [ dupd apply-identity? ] find nip ; + +: apply-identities ( node -- node/f ) + dup find-identity dup [ + second swap dataflow-with [ subst-node ] keep + ] [ + 3drop f + ] ifte ; [ + fixnum+ bignum+ float+ ] { { { @ 0 } [ drop ] } @@ -92,8 +97,8 @@ SYMBOL: @ [ * fixnum* bignum* float* ] { { { @ 1 } [ drop ] } { { 1 @ } [ nip ] } - { { @ 0 } [ 2drop 0 ] } - { { 0 @ } [ 2drop 0 ] } + { { @ 0 } [ nip ] } + { { 0 @ } [ drop ] } { { @ -1 } [ drop 0 swap - ] } { { -1 @ } [ nip 0 swap - ] } } define-identities @@ -116,19 +121,19 @@ SYMBOL: @ ! } define-identities [ bitand fixnum-bitand bignum-bitand ] { - { { @ -1 } [ drop ] } - { { -1 @ } [ nip ] } - { { @ @ } [ drop ] } - { { @ 0 } [ 2drop 0 ] } - { { 0 @ } [ 2drop 0 ] } + { { @ -1 } [ drop ] } + { { -1 @ } [ nip ] } + { { @ @ } [ drop ] } + { { @ 0 } [ nip ] } + { { 0 @ } [ drop ] } } define-identities [ bitor fixnum-bitor bignum-bitor ] { { { @ 0 } [ drop ] } { { 0 @ } [ nip ] } { { @ @ } [ drop ] } - { { @ -1 } [ 2drop -1 ] } - { { -1 @ } [ 2drop -1 ] } + { { @ -1 } [ nip ] } + { { -1 @ } [ drop ] } } define-identities [ bitxor fixnum-bitxor bignum-bitxor ] { @@ -140,7 +145,7 @@ SYMBOL: @ } define-identities [ shift fixnum-shift bignum-shift ] { - { { 0 @ } [ 2drop 0 ] } + { { 0 @ } [ drop ] } { { @ 0 } [ drop ] } } define-identities @@ -163,3 +168,14 @@ SYMBOL: @ [ eq? number= = ] { { { @ @ } [ 2drop t ] } } define-identities + +M: #call optimize-node* ( node -- node/t ) + { + { [ dup node-param not ] [ node-successor ] } + { [ dup partial-eval? ] [ partial-eval ] } + { [ dup find-identity nip ] [ apply-identities ] } + { [ dup optimizer-hooks ] [ optimize-hooks ] } + { [ dup inlining-class ] [ inline-method ] } + { [ dup optimize-predicate? ] [ optimize-predicate ] } + { [ t ] [ drop t ] } + } cond ; diff --git a/library/test/benchmark/sort.factor b/library/test/benchmark/sort.factor index 5099c22696..b648796785 100644 --- a/library/test/benchmark/sort.factor +++ b/library/test/benchmark/sort.factor @@ -1,13 +1,7 @@ IN: temporary -USE: lists -USE: kernel -USE: math -USE: namespaces -USE: random -USE: test -USE: compiler +USING: compiler kernel math sequences test ; : sort-benchmark - [ 100000 [ 0 10000 random-int , ] times ] make-vector [ - ] sort drop ; compiled + 100000 [ drop 0 10000 random-int ] map [ - ] sort drop ; compiled [ ] [ sort-benchmark ] unit-test diff --git a/library/test/compiler/intrinsics.factor b/library/test/compiler/intrinsics.factor index d77988d6b7..5f75ed09ca 100644 --- a/library/test/compiler/intrinsics.factor +++ b/library/test/compiler/intrinsics.factor @@ -3,9 +3,6 @@ USING: compiler kernel kernel-internals lists math math-internals test words ; ! Make sure that intrinsic ops compile to correct code. -: compile-1 ( quot -- word ) - gensym [ swap define-compound ] keep dup compile execute ; - [ 1 ] [ [[ 1 2 ]] [ 0 slot ] compile-1 ] unit-test [ 1 ] [ [ [[ 1 2 ]] 0 slot ] compile-1 ] unit-test [ 3 ] [ 3 1 2 cons [ [ 0 set-slot ] keep ] compile-1 car ] unit-test diff --git a/library/ui/splitters.factor b/library/ui/splitters.factor index 525a67726e..9cbcb22e84 100644 --- a/library/ui/splitters.factor +++ b/library/ui/splitters.factor @@ -48,12 +48,12 @@ C: splitter ( first second split vector -- splitter ) dup splitter-split swap rectangle-dim n*v divider-size 1/2 v*n v- ; -: splitter-layout ( splitter -- [ a b c ] ) +: splitter-layout ( splitter -- { a b c } ) [ dup splitter-part , divider-size , dup rectangle-dim divider-size v- swap splitter-part v- , - ] make-list ; + ] make-vector ; M: splitter layout* ( splitter -- ) dup splitter-layout packed-layout ;