should fix in 0.82:
-- type inference busted for tuple constructors
- constant branch folding
- fast-slot stuff
- 3 >n fep
"fixnum?" "math" create t "inline" set-word-prop
"fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin
-"fixnum" "math" create 0 "math-priority" set-word-prop
"fixnum" "math" create ">fixnum" "math" lookup unit "coercer" set-word-prop
"bignum?" "math" create t "inline" set-word-prop
"bignum" "math" create 1 "bignum?" "math" create { } define-builtin
-"bignum" "math" create 1 "math-priority" set-word-prop
"bignum" "math" create ">bignum" "math" lookup unit "coercer" set-word-prop
"cons?" "lists" create t "inline" set-word-prop
{ 0 integer { "numerator" "math" } f }
{ 1 integer { "denominator" "math" } f }
} define-builtin
-"ratio" "math" create 2 "math-priority" set-word-prop
"float?" "math" create t "inline" set-word-prop
"float" "math" create 5 "float?" "math" create { } define-builtin
-"float" "math" create 3 "math-priority" set-word-prop
"float" "math" create ">float" "math" lookup unit "coercer" set-word-prop
"complex?" "math" create t "inline" set-word-prop
{ 0 real { "real" "math" } f }
{ 1 real { "imaginary" "math" } f }
} define-builtin
-"complex" "math" create 4 "math-priority" set-word-prop
"alien" "alien" create 7 "alien?" "alien" create
{ { 1 object { "underlying-alien" "alien" } f } } define-builtin
: class-methods ( classname -- seq )
objc-meta-class objc-methods ;
-: make-dip ( quot n -- quot )
- dup \ >r <array> -rot \ r> <array> append3 ;
-
: <super> ( receiver class -- super )
"objc-super" <c-object>
[ set-objc-super-class ] keep
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
-IN: lists USING: errors generic kernel math sequences ;
+IN: lists USING: arrays errors generic kernel math sequences ;
M: f car ;
M: f cdr ;
: curry ( obj quot -- quot ) >r literalize r> cons ;
+: make-dip ( quot n -- quot )
+ dup \ >r <array> -rot \ r> <array> append3 >list ;
+
: (>list) ( n i seq -- list )
pick pick <= [
3drop [ ]
[ 1 <vector> ] unless* [ push ] keep ;
: bounds-check? ( n seq -- ? )
- over 0 >= [ length < ] [ 2drop f ] if ;
+ over 0 >= [ length < ] [ 2drop f ] if ; inline
: ?nth ( n seq/f -- elt/f )
2dup bounds-check? [ nth ] [ 2drop f ] if ;
} define-optimizers
: useless-coerce? ( node -- )
- dup node-in-d first over node-class
+ dup 0 node-class#
swap node-param "infer-effect" word-prop second first eq? ;
: call>no-op ( node -- node )
: node-class ( value node -- class )
node-classes ?hash [ object ] unless* ;
+: node-class# ( node n -- class )
+ swap [ node-in-d reverse-slice nth ] keep node-class ;
+
! Variables used by the class inferencer
! Current value --> class mapping
! Copyright (C) 2004, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: optimizer
-USING: arrays generic hashtables inference kernel lists math
-namespaces sequences words ;
-
-! Method inlining optimization
-: dispatch# ( #call -- n )
- node-param "combination" word-prop first ;
-
-: dispatching-class ( node -- seq )
- dup dispatch# over node-in-d reverse-slice nth
- swap node-class ;
-
-: already-inlined? ( node -- ? )
- #! Was this node inlined from definition of 'word'?
- dup node-param swap node-history memq? ;
-
-: specific-method ( word class -- ? ) swap order min-class ;
-
-: inlining-class ( #call -- class )
- #! If the generic dispatch can be eliminated, return the
- #! class of the method that will always be invoked here.
- dup node-param swap dispatching-class
- specific-method ;
-
-: will-inline-method ( node -- quot/t )
- #! t indicates failure
- dup inlining-class dup [
- swap node-param "methods" word-prop hash
- ] [
- 2drop t
- ] if ;
+USING: arrays generic hashtables inference kernel
+kernel-internals lists math namespaces sequences words ;
+! Some utilities for splicing in dataflow IR subtrees
: post-inline ( #return/#values #call/#merge -- )
dup [
[
] [
over node-in-d dataflow-with
[ >r node-param r> remember-node ] 2keep
- [ subst-node ] keep
+ [ subst-node ] keep [ infer-classes ] keep
] if ;
-: inline-standard-method ( node -- node )
- dup will-inline-method (inline-method) ;
+! Single dispatch method inlining optimization
+: dispatch# ( #call -- n )
+ node-param "combination" word-prop first ;
-: comparable? ( actual testing -- ? )
- #! If actual is a subset of testing or if the two classes
- #! are disjoint, return t.
- 2dup class< >r classes-intersect? not r> or ;
+: dispatching-class ( node -- seq ) dup dispatch# node-class# ;
-: optimize-predicate? ( #call -- ? )
- dup node-param "predicating" word-prop dup [
- >r dup node-in-d node-classes* first r> comparable?
+: already-inlined? ( node -- ? )
+ #! Was this node inlined from definition of 'word'?
+ dup node-param swap node-history memq? ;
+
+: specific-method ( word class -- ? ) swap order min-class ;
+
+: inlining-class ( #call -- class )
+ #! If the generic dispatch can be eliminated, return the
+ #! class of the method that will always be invoked here.
+ dup node-param swap dispatching-class
+ specific-method ;
+
+: will-inline-method ( node -- quot/t )
+ #! t indicates failure
+ dup inlining-class dup [
+ swap node-param "methods" word-prop hash
] [
- 2drop f
+ 2drop t
] if ;
-: inline-literals ( node literals -- node )
- #! Make #shuffle -> #push -> #return -> successor
- over drop-inputs [
- >r >list [ literalize ] map dataflow [ subst-node ] keep
- r> set-node-successor
- ] keep ;
+: inline-standard-method ( node -- node )
+ dup will-inline-method (inline-method) ;
-: optimize-predicate ( #call -- node )
- dup node-param "predicating" word-prop >r
- dup dup node-in-d node-classes* first r> class<
- 1array inline-literals ;
+: inline-standard-method? ( #call -- ? )
+ dup already-inlined? not swap node-param standard-generic?
+ and ;
+! Partial dispatch of 2generic words
: math-both-known? ( word left right -- ? )
math-class-max specific-method ;
-
-: partial-math ( word class left/right -- vtable )
- dup \ dup \ over ? [
- ( word class left/right class )
- >r 3dup r> swap [ swap ] unless math-method
- ] math-vtable >r 3drop r> ;
+
+: max-tag ( class -- n ) types peek 1+ num-tags min ;
+
+: left-partial-math ( word left right -- quot/t )
+ #! The left type is known; dispatch on right
+ \ dup swap max-tag
+ [ >r 2dup r> math-method ] math-vtable* 2nip ;
+
+: right-partial-math ( word left right -- quot/t )
+ #! The right type is known; dispatch on left
+ \ over rot max-tag
+ [ >r 2dup r> swap math-method ] math-vtable* 2nip ;
: will-inline-math-method ( word left right -- quot/t )
#! t indicates failure
{
{ [ 3dup math-both-known? ] [ math-method ] }
- { [ 3dup drop specific-method ] [ drop t partial-math ] }
- { [ 3dup nip specific-method ] [ nip f partial-math ] }
+ { [ 3dup drop specific-method ] [ left-partial-math ] }
+ { [ 3dup nip specific-method ] [ right-partial-math ] }
{ [ t ] [ 3drop t ] }
} cond ;
: inline-math-method ( #call -- node )
- dup node-param
- over dup node-in-d [ swap node-class ] map-with first2
+ dup node-param over 1 node-class# pick 0 node-class#
will-inline-math-method (inline-method) ;
-: inline-standard-method? ( #call -- ? )
- dup already-inlined? not swap node-param standard-generic?
- and ;
-
: inline-math-method? ( #call -- ? )
dup node-history empty? swap node-param 2generic? and ;
{ [ dup inline-math-method? ] [ inline-math-method ] }
{ [ t ] [ drop t ] }
} cond ;
+
+! Resolve type checks at compile time where possible
+: comparable? ( actual testing -- ? )
+ #! If actual is a subset of testing or if the two classes
+ #! are disjoint, return t.
+ 2dup class< >r classes-intersect? not r> or ;
+
+: optimize-predicate? ( #call -- ? )
+ dup node-param "predicating" word-prop dup [
+ >r dup 0 node-class# r> comparable?
+ ] [
+ 2drop f
+ ] if ;
+
+: inline-literals ( node literals -- node )
+ #! Make #shuffle -> #push -> #return -> successor
+ over drop-inputs [
+ >r >list [ literalize ] map dataflow [ subst-node ] keep
+ r> set-node-successor
+ ] keep ;
+
+: optimize-predicate ( #call -- node )
+ dup node-param "predicating" word-prop >r
+ dup 0 node-class# r> class< 1array inline-literals ;
] H{
{ +input { { f "val" } { f "obj" } { f "slot" } } }
{ +scratch { { f "x" } } }
- { +clobber { "obj" } }
+ { +clobber { "obj" "slot" } }
} define-intrinsic
\ set-char-slot [
] H{
{ +input { { f "val" } { f "slot" } { f "obj" } } }
{ +scratch { { f "x" } } }
- { +clobber { "obj" } }
+ { +clobber { "val" "slot" "obj" } }
} define-intrinsic
: define-binary-op ( word op -- )
] hash-each ;
: types ( class -- types )
- [ (types) ] make-hash hash-keys ;
+ [ (types) ] make-hash hash-keys natural-sort ;
DEFER: class<
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: generic
-USING: errors generic hashtables kernel kernel-internals lists
-math namespaces sequences words ;
+USING: arrays errors generic hashtables kernel kernel-internals
+lists math namespaces sequences words ;
! Math combination for generic dyadic upgrading arithmetic.
-: math-priority ( class -- n )
- dup "members" word-prop [
- 0 [ math-priority max ] reduce
- ] [
- "math-priority" word-prop [ 100 ] unless*
- ] ?if ;
+: first/last ( seq -- pair ) dup first swap peek 2array ;
-: math-class< ( class class -- ? )
- [ math-priority ] 2apply < ;
+: math-class-compare ( class class -- n )
+ [
+ dup number class<
+ [ types first/last ] [ drop { 100 100 } ] if
+ ] 2apply <=> ;
: math-class-max ( class class -- class )
- [ swap math-class< ] 2keep ? ;
+ [ math-class-compare 0 > ] 2keep ? ;
+
+: (math-upgrade) ( max class -- quot )
+ dupd = [ drop [ ] ] [ "coercer" word-prop ] if ;
: math-upgrade ( left right -- quot )
- 2dup math-class< [
- nip "coercer" word-prop
- dup [ [ >r ] swap [ r> ] append3 ] when
- ] [
- 2dup swap math-class< [
- drop "coercer" word-prop
- ] [
- 2drop [ ]
- ] if
- ] if ;
+ [ math-class-max ] 2keep
+ >r over r> (math-upgrade)
+ >r (math-upgrade) dup [ 1 make-dip ] when r> append ;
TUPLE: no-math-method left right generic ;
2drop object-method
] if ;
-: math-vtable ( picker quot -- quot )
+: math-vtable* ( picker max quot -- quot )
[
- swap , \ tag ,
- [ num-tags [ type>class ] map swap map % ] { } make ,
+ rot , \ tag ,
+ [ >r [ type>class ] map r> map % ] { } make ,
\ dispatch ,
] [ ] make ; inline
+: math-vtable ( picker quot -- quot )
+ num-tags swap math-vtable* ; inline
+
: math-class? ( object -- ? )
dup word? [ "math-priority" word-prop ] [ drop f ] if ;
! Copyright (C) 2004, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
IN: kernel
-USING: generic kernel-internals math-internals ;
+USING: generic kernel-internals math math-internals ;
: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline
! These words are unsafe. Don't use them.
: declare ( types -- ) drop ;
-: array-capacity 1 slot ; inline
+: array-capacity 1 slot { fixnum } declare ; inline
: array-nth swap 2 fixnum+fast slot ; inline
: set-array-nth swap 2 fixnum+fast set-slot ; inline
[ t ] [ \ + 2generic? ] unit-test
[ "SYMBOL: not-a-class C: not-a-class ;" parse ] unit-test-fails
+
+! Test math-combination
+[ [ >r >float r> ] ] [ \ real \ float math-upgrade ] unit-test
+[ [ >float ] ] [ \ float \ real math-upgrade ] unit-test
+[ [ >r >bignum r> ] ] [ \ fixnum \ bignum math-upgrade ] unit-test
+[ [ >float ] ] [ \ float \ integer math-upgrade ] unit-test
+[ number ] [ \ number \ float math-class-max ] unit-test
+[ float ] [ \ real \ float math-class-max ] unit-test
projects / factor.git / commitdiff