diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 579f039da7..d7acafcbb4 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,6 +1,5 @@ should fix in 0.82: -- type inference busted for tuple constructors - constant branch folding - fast-slot stuff - 3 >n fep diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index ac6724851f..6e4911ea2c 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -258,12 +258,10 @@ num-types f builtins set "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 @@ -279,11 +277,9 @@ num-types f builtins set { 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 @@ -292,7 +288,6 @@ num-types f builtins set { 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 diff --git a/library/cocoa/utilities.factor b/library/cocoa/utilities.factor index f35555a915..966e456f3e 100644 --- a/library/cocoa/utilities.factor +++ b/library/cocoa/utilities.factor @@ -119,9 +119,6 @@ H{ : class-methods ( classname -- seq ) objc-meta-class objc-methods ; -: make-dip ( quot n -- quot ) - dup \ >r -rot \ r> append3 ; - : ( receiver class -- super ) "objc-super" [ set-objc-super-class ] keep diff --git a/library/collections/lists.factor b/library/collections/lists.factor index 79c6aa5ff8..da71c523b9 100644 --- a/library/collections/lists.factor +++ b/library/collections/lists.factor @@ -1,6 +1,6 @@ ! 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 ; @@ -79,6 +79,9 @@ M: cons = ( obj cons -- ? ) : curry ( obj quot -- quot ) >r literalize r> cons ; +: make-dip ( quot n -- quot ) + dup \ >r -rot \ r> append3 >list ; + : (>list) ( n i seq -- list ) pick pick <= [ 3drop [ ] diff --git a/library/collections/sequences.factor b/library/collections/sequences.factor index 6ce835d229..fbcd04dfbb 100644 --- a/library/collections/sequences.factor +++ b/library/collections/sequences.factor @@ -26,7 +26,7 @@ GENERIC: reverse-slice ( seq -- seq ) flushable [ 1 ] 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 ; diff --git a/library/compiler/optimizer/call-optimizers.factor b/library/compiler/optimizer/call-optimizers.factor index 4d627d5d3e..e74453ad0b 100644 --- a/library/compiler/optimizer/call-optimizers.factor +++ b/library/compiler/optimizer/call-optimizers.factor @@ -63,7 +63,7 @@ math math-internals sequences words ; } 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 ) diff --git a/library/compiler/optimizer/class-infer.factor b/library/compiler/optimizer/class-infer.factor index 5a7d2cce4f..04bb487765 100644 --- a/library/compiler/optimizer/class-infer.factor +++ b/library/compiler/optimizer/class-infer.factor @@ -9,6 +9,9 @@ kernel-internals math namespaces sequences words ; : 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 diff --git a/library/compiler/optimizer/inline-methods.factor b/library/compiler/optimizer/inline-methods.factor index 92ce37745e..de85a18be8 100644 --- a/library/compiler/optimizer/inline-methods.factor +++ b/library/compiler/optimizer/inline-methods.factor @@ -1,37 +1,10 @@ ! 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 [ [ @@ -54,12 +27,82 @@ namespaces sequences words ; ] [ over node-in-d dataflow-with [ >r node-param r> remember-node ] 2keep - [ subst-node ] keep + [ subst-node ] keep [ infer-classes ] keep + ] if ; + +! Single dispatch method inlining optimization +: dispatch# ( #call -- n ) + node-param "combination" word-prop first ; + +: dispatching-class ( node -- seq ) dup dispatch# 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 ; : inline-standard-method ( node -- node ) dup will-inline-method (inline-method) ; +: 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 ; + +: 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 ] [ left-partial-math ] } + { [ 3dup nip specific-method ] [ right-partial-math ] } + { [ t ] [ 3drop t ] } + } cond ; + +: inline-math-method ( #call -- node ) + dup node-param over 1 node-class# pick 0 node-class# + will-inline-math-method (inline-method) ; + +: inline-math-method? ( #call -- ? ) + dup node-history empty? swap node-param 2generic? and ; + +: inline-method ( #call -- node ) + { + { [ dup inline-standard-method? ] [ inline-standard-method ] } + { [ 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. @@ -67,7 +110,7 @@ namespaces sequences words ; : optimize-predicate? ( #call -- ? ) dup node-param "predicating" word-prop dup [ - >r dup node-in-d node-classes* first r> comparable? + >r dup 0 node-class# r> comparable? ] [ 2drop f ] if ; @@ -81,42 +124,4 @@ namespaces sequences words ; : optimize-predicate ( #call -- node ) dup node-param "predicating" word-prop >r - dup dup node-in-d node-classes* first r> class< - 1array inline-literals ; - -: 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> ; - -: 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 ] } - { [ t ] [ 3drop t ] } - } cond ; - -: inline-math-method ( #call -- node ) - dup node-param - over dup node-in-d [ swap node-class ] map-with first2 - 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 ; - -: inline-method ( #call -- node ) - { - { [ dup inline-standard-method? ] [ inline-standard-method ] } - { [ dup inline-math-method? ] [ inline-math-method ] } - { [ t ] [ drop t ] } - } cond ; + dup 0 node-class# r> class< 1array inline-literals ; diff --git a/library/compiler/ppc/intrinsics.factor b/library/compiler/ppc/intrinsics.factor index 9c48ea3844..9432aee2eb 100644 --- a/library/compiler/ppc/intrinsics.factor +++ b/library/compiler/ppc/intrinsics.factor @@ -67,7 +67,7 @@ math-internals namespaces sequences words ; ] H{ { +input { { f "val" } { f "obj" } { f "slot" } } } { +scratch { { f "x" } } } - { +clobber { "obj" } } + { +clobber { "obj" "slot" } } } define-intrinsic \ set-char-slot [ @@ -77,7 +77,7 @@ math-internals namespaces sequences words ; ] H{ { +input { { f "val" } { f "slot" } { f "obj" } } } { +scratch { { f "x" } } } - { +clobber { "obj" } } + { +clobber { "val" "slot" "obj" } } } define-intrinsic : define-binary-op ( word op -- ) diff --git a/library/generic/generic.factor b/library/generic/generic.factor index f1c7fa9948..50dd653699 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -39,7 +39,7 @@ SYMBOL: builtins ] hash-each ; : types ( class -- types ) - [ (types) ] make-hash hash-keys ; + [ (types) ] make-hash hash-keys natural-sort ; DEFER: class< diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor index c7d2af0882..8f2a0a05a8 100644 --- a/library/generic/math-combination.factor +++ b/library/generic/math-combination.factor @@ -1,35 +1,29 @@ ! 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 ; @@ -52,13 +46,16 @@ 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 ; diff --git a/library/kernel.factor b/library/kernel.factor index 871a0889b6..c18ff92ce1 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -1,7 +1,7 @@ ! 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 @@ -81,7 +81,7 @@ IN: kernel-internals ! 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 diff --git a/library/test/generic.factor b/library/test/generic.factor index 84f044a2e4..c1075377e2 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -200,3 +200,11 @@ TUPLE: delegating ; [ 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