179 lines
4.7 KiB
Factor
179 lines
4.7 KiB
Factor
! Copyright (C) 2005 Slava Pestov.
|
|
! See http://factor.sf.net/license.txt for BSD license.
|
|
IN: inference
|
|
USING: errors generic hashtables kernel math math-internals
|
|
sequences vectors words ;
|
|
|
|
! A system for associating dataflow optimizers with words.
|
|
|
|
: optimizer-hooks ( node -- conditions )
|
|
node-param "optimizer-hooks" word-prop ;
|
|
|
|
: optimize-hooks ( node -- node/t )
|
|
dup optimizer-hooks cond ;
|
|
|
|
: define-optimizers ( word optimizers -- )
|
|
{ [ t ] [ drop t ] } add "optimizer-hooks" set-word-prop ;
|
|
|
|
: partial-eval? ( #call -- ? )
|
|
dup node-param "foldable" word-prop [
|
|
dup node-in-d [
|
|
dup literal?
|
|
[ 2drop t ] [ swap node-literals hash* ] ifte
|
|
] all-with?
|
|
] [
|
|
drop f
|
|
] ifte ;
|
|
|
|
: literal-in-d ( #call -- inputs )
|
|
dup node-in-d [
|
|
dup literal?
|
|
[ nip literal-value ] [ swap node-literals hash ] ifte
|
|
] map-with ;
|
|
|
|
: partial-eval ( #call -- node )
|
|
dup literal-in-d over node-param
|
|
[ with-datastack ] [
|
|
[ 3drop t ] [ inline-literals ] ifte
|
|
] catch ;
|
|
|
|
: flip-branches ( #ifte -- )
|
|
dup node-children 2unseq swap 2vector swap set-node-children ;
|
|
|
|
\ not {
|
|
{ [ dup node-successor #ifte? ] [ node-successor dup flip-branches ] }
|
|
} define-optimizers
|
|
|
|
: disjoint-eq? ( node -- ? )
|
|
dup node-classes swap node-in-d
|
|
[ swap hash ] map-with
|
|
2unseq 2dup and [ classes-intersect? not ] [ 2drop f ] ifte ;
|
|
|
|
\ eq? {
|
|
{ [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
|
|
} define-optimizers
|
|
|
|
! Arithmetic identities
|
|
SYMBOL: @
|
|
|
|
: define-identities ( words identities -- )
|
|
swap [ swap "identities" set-word-prop ] each-with ;
|
|
|
|
: literals-match? ( values template -- ? )
|
|
[
|
|
over literal? [ >r literal-value r> ] [ nip @ ] ifte =
|
|
] 2map conjunction ;
|
|
|
|
: values-match? ( values template -- ? )
|
|
[ @ = [ drop f ] unless ] 2map [ ] subset [ eq? ] every? ;
|
|
|
|
: apply-identity? ( values identity -- ? )
|
|
first 2dup literals-match? >r values-match? r> and ;
|
|
|
|
: 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 ] }
|
|
{ { 0 @ } [ nip ] }
|
|
} define-identities
|
|
|
|
[ - fixnum- bignum- float- ] {
|
|
{ { @ 0 } [ drop ] }
|
|
{ { @ @ } [ 2drop 0 ] }
|
|
} define-identities
|
|
|
|
[ * fixnum* bignum* float* ] {
|
|
{ { @ 1 } [ drop ] }
|
|
{ { 1 @ } [ nip ] }
|
|
{ { @ 0 } [ nip ] }
|
|
{ { 0 @ } [ drop ] }
|
|
{ { @ -1 } [ drop 0 swap - ] }
|
|
{ { -1 @ } [ nip 0 swap - ] }
|
|
} define-identities
|
|
|
|
[ / /i /f fixnum/i fixnum/f bignum/i bignum/f float/f ] {
|
|
{ { @ 1 } [ drop ] }
|
|
{ { @ -1 } [ drop 0 swap - ] }
|
|
} define-identities
|
|
|
|
[ rem mod fixnum-mod bignum-mod ] {
|
|
{ { @ 1 } [ 2drop 0 ] }
|
|
} define-identities
|
|
|
|
! [ ^ ] {
|
|
! { { 1 @ } [ 2drop 1 ] }
|
|
! { { @ 1 } [ drop ] }
|
|
! { { @ 2 } [ drop dup * ] }
|
|
! { { @ -1 } [ drop 1 swap / ] }
|
|
! { { @ -2 } [ drop dup * 1 swap / ] }
|
|
! } define-identities
|
|
|
|
[ bitand fixnum-bitand bignum-bitand ] {
|
|
{ { @ -1 } [ drop ] }
|
|
{ { -1 @ } [ nip ] }
|
|
{ { @ @ } [ drop ] }
|
|
{ { @ 0 } [ nip ] }
|
|
{ { 0 @ } [ drop ] }
|
|
} define-identities
|
|
|
|
[ bitor fixnum-bitor bignum-bitor ] {
|
|
{ { @ 0 } [ drop ] }
|
|
{ { 0 @ } [ nip ] }
|
|
{ { @ @ } [ drop ] }
|
|
{ { @ -1 } [ nip ] }
|
|
{ { -1 @ } [ drop ] }
|
|
} define-identities
|
|
|
|
[ bitxor fixnum-bitxor bignum-bitxor ] {
|
|
{ { @ 0 } [ drop ] }
|
|
{ { 0 @ } [ nip ] }
|
|
{ { @ -1 } [ drop bitnot ] }
|
|
{ { -1 @ } [ nip bitnot ] }
|
|
{ { @ @ } [ 2drop 0 ] }
|
|
} define-identities
|
|
|
|
[ shift fixnum-shift bignum-shift ] {
|
|
{ { 0 @ } [ drop ] }
|
|
{ { @ 0 } [ drop ] }
|
|
} define-identities
|
|
|
|
[ < fixnum< bignum< float< ] {
|
|
{ { @ @ } [ 2drop f ] }
|
|
} define-identities
|
|
|
|
[ <= fixnum<= bignum<= float<= ] {
|
|
{ { @ @ } [ 2drop t ] }
|
|
} define-identities
|
|
|
|
[ > fixnum> bignum> float>= ] {
|
|
{ { @ @ } [ 2drop f ] }
|
|
} define-identities
|
|
|
|
[ >= fixnum>= bignum>= float>= ] {
|
|
{ { @ @ } [ 2drop t ] }
|
|
} define-identities
|
|
|
|
[ 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 ;
|