New optimizations: useless coerce elimination, builtin slot type declarations

library/bootstrap/boot-stage2.factor

@@ -23,6 +23,9 @@ H{ } clone help-graph set-global xref-articles
 
     "Compiling base..." print flush
 
+    \ slot \ set-slot [ usage ] 2apply append
+    [ try-compile ] each
+
     \ + compile
     \ = compile
     { "kernel" "sequences" "assembler" } compile-vocabs

library/bootstrap/primitives.factor

@@ -268,11 +268,17 @@ num-types f <array> builtins set
 
 "cons?" "lists" create t "inline" set-word-prop
 "cons" "lists" create 2 "cons?" "lists" create
-{ { 0 { "car" "lists" } f } { 1 { "cdr" "lists" } f } } define-builtin
+{
+    { 0 object { "car" "lists" } f }
+    { 1 object { "cdr" "lists" } f }
+} define-builtin
 
 "ratio?" "math" create t "inline" set-word-prop
 "ratio" "math" create 4 "ratio?" "math" create
-{ { 0 { "numerator" "math" } f } { 1 { "denominator" "math" } f } } define-builtin
+{
+    { 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
@@ -282,11 +288,14 @@ num-types f <array> builtins set
 
 "complex?" "math" create t "inline" set-word-prop
 "complex" "math" create 6 "complex?" "math" create
-{ { 0 { "real" "math" } f } { 1 { "imaginary" "math" } f } } define-builtin
+{
+    { 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 { "underlying-alien" "alien" } f } } define-builtin
+{ { 1 object { "underlying-alien" "alien" } f } } define-builtin
 
 "array?" "arrays" create t "inline" set-word-prop
 "array" "arrays" create 8 "array?" "arrays" create
@@ -298,49 +307,115 @@ num-types f <array> builtins set
 "hashtable?" "hashtables" create t "inline" set-word-prop
 "hashtable" "hashtables" create 10 "hashtable?" "hashtables" create
 {
-    { 1 { "hash-count" "hashtables" } { "set-hash-count" "hashtables-internals" } }
+    {
-    { 2 { "hash-deleted" "hashtables" } { "set-hash-deleted" "hashtables-internals" } }
+        1
-    { 3 { "hash-array" "hashtables-internals" } { "set-hash-array" "hashtables-internals" } }
+        fixnum
+        { "hash-count" "hashtables" }
+        { "set-hash-count" "hashtables-internals" }
+    } {
+        2
+        fixnum
+        { "hash-deleted" "hashtables" }
+        { "set-hash-deleted" "hashtables-internals" }
+    } {
+        3
+        array
+        { "hash-array" "hashtables-internals" }
+        { "set-hash-array" "hashtables-internals" }
+    }
 } define-builtin
 
 "vector?" "vectors" create t "inline" set-word-prop
 "vector" "vectors" create 11 "vector?" "vectors" create
 {
-    { 1 { "length" "sequences" } { "set-fill" "sequences-internals" } }
+    {
-    { 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
+        1
+        fixnum
+        { "length" "sequences" }
+        { "set-fill" "sequences-internals" }
+    } {
+        2
+        array
+        { "underlying" "sequences-internals" }
+        { "set-underlying" "sequences-internals" }
+    }
 } define-builtin
 
 "string?" "strings" create t "inline" set-word-prop
 "string" "strings" create 12 "string?" "strings" create
 {
-    { 1 { "length" "sequences" } f }
+    {
-    { 2 { "string-hashcode" "kernel-internals" } { "set-string-hashcode" "kernel-internals" } }
+        1
+        fixnum
+        { "length" "sequences" }
+        f
+    } {
+        2
+        fixnum
+        { "string-hashcode" "kernel-internals" }
+        { "set-string-hashcode" "kernel-internals" }
+    }
 } define-builtin
 
 "sbuf?" "strings" create t "inline" set-word-prop 
 "sbuf" "strings" create 13 "sbuf?" "strings" create
 {
-    { 1 { "length" "sequences" } { "set-fill" "sequences-internals" } }
+    {
-    { 2 { "underlying" "sequences-internals" } { "set-underlying" "sequences-internals" } }
+        1
+        fixnum
+        { "length" "sequences" }
+        { "set-fill" "sequences-internals" }
+    }
+    {
+        2
+        string
+        { "underlying" "sequences-internals" }
+        { "set-underlying" "sequences-internals" }
+    }
 } define-builtin
 
 "wrapper?" "kernel" create t "inline" set-word-prop
 "wrapper" "kernel" create 14 "wrapper?" "kernel" create
-{ { 1 { "wrapped" "kernel" } f } } define-builtin
+{ { 1 object { "wrapped" "kernel" } f } } define-builtin
 
 "dll?" "alien" create t "inline" set-word-prop
 "dll" "alien" create 15 "dll?" "alien" create
-{ { 1 { "dll-path" "alien" } f } } define-builtin
+{ { 1 object { "dll-path" "alien" } f } } define-builtin
 
 "word?" "words" create t "inline" set-word-prop
 "word" "words" create 16 "word?" "words" create
 {
-    { 1 { "hashcode" "kernel" } f }
+    { 1 fixnum { "hashcode" "kernel" } f }
-    { 2 { "word-name" "words" } f }
+    {
-    { 3 { "word-vocabulary" "words" } { "set-word-vocabulary" "words" } }
+        2
-    { 4 { "word-primitive" "words" } { "set-word-primitive" "words" } }
+        object
-    { 5 { "word-def" "words" } { "set-word-def" "words" } }
+        { "word-name" "words" }
-    { 6 { "word-props" "words" } { "set-word-props" "words" } }
+        f
+    }
+    {
+        3
+        object
+        { "word-vocabulary" "words" }
+        { "set-word-vocabulary" "words" }
+    }
+    {
+        4
+        object
+        { "word-primitive" "words" }
+        { "set-word-primitive" "words" }
+    }
+    {
+        5
+        object
+        { "word-def" "words" }
+        { "set-word-def" "words" }
+    }
+    {
+        6
+        object
+        { "word-props" "words" }
+        { "set-word-props" "words" }
+    }
 } define-builtin
 
 "tuple?" "kernel" create t "inline" set-word-prop

library/collections/hashtables.factor

@@ -9,9 +9,10 @@ TUPLE: tombstone ;
 : ((empty)) T{ tombstone f } ; inline
 : ((tombstone)) T{ tombstone t } ; inline
 
-: hash@ ( key keys -- n ) >r hashcode r> length 2 /i rem 2 * ;
+: hash@ ( key keys -- n )
+    >r hashcode r> length 2 /i rem 2 * ; inline
 
-: probe ( heys i -- hash i ) 2 + over length mod ;
+: probe ( heys i -- hash i ) 2 + over length mod ; inline
 
 : (key@) ( key keys i -- n )
     3dup swap nth-unsafe {
@@ -21,12 +22,14 @@ TUPLE: tombstone ;
         { [ t ] [ probe (key@) ] }
     } cond ;
 
-: key@ ( key hash -- n ) hash-array 2dup hash@ (key@) ;
+: key@ ( key hash -- n )
+    hash-array 2dup hash@ (key@) ; inline
 
 : if-key ( key hash true false -- | true: index key hash -- )
     >r >r [ key@ ] 2keep pick -1 > r> r> if ; inline
 
-: <hash-array> ( n -- array ) 1+ 4 * ((empty)) <array> ;
+: <hash-array> ( n -- array )
+    1+ 4 * ((empty)) <array> ; inline
 
 : init-hash ( hash -- )
     0 over set-hash-count 0 swap set-hash-deleted ;
@@ -39,35 +42,38 @@ TUPLE: tombstone ;
         2drop 2nip
     ] [
         = [ 2nip ] [ probe (new-key@) ] if
-    ] if ;
+    ] if ; inline
 
 : new-key@ ( key hash -- n )
-    hash-array 2dup hash@ (new-key@) ;
+    hash-array 2dup hash@ (new-key@) ; inline
 
 : nth-pair ( n seq -- key value )
-    [ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ;
+    [ nth-unsafe ] 2keep >r 1+ r> nth-unsafe ; inline
 
 : set-nth-pair ( value key n seq -- )
-    [ set-nth-unsafe ] 2keep >r 1+ r> set-nth-unsafe ;
+    [ set-nth-unsafe ] 2keep >r 1+ r> set-nth-unsafe ; inline
 
-: hash-count+ dup hash-count 1+ swap set-hash-count ;
+: hash-count+
+    dup hash-count 1+ swap set-hash-count ; inline
 
-: hash-deleted+ dup hash-deleted 1+ swap set-hash-deleted ;
+: hash-deleted+
+    dup hash-deleted 1+ swap set-hash-deleted ; inline
 
-: hash-deleted- dup hash-deleted 1- swap set-hash-deleted ;
+: hash-deleted-
+    dup hash-deleted 1- swap set-hash-deleted ; inline
 
 : change-size ( hash old -- )
     dup ((tombstone)) eq? [
         drop hash-deleted-
     ] [
         ((empty)) eq? [ hash-count+ ] [ drop ] if
-    ] if ;
+    ] if ; inline
 
 : (set-hash) ( value key hash -- )
     2dup new-key@ swap
     [ hash-array 2dup nth-unsafe ] keep
     ( value key n hash-array old hash )
-    swap change-size set-nth-pair ;
+    swap change-size set-nth-pair ; inline
 
 : (each-pair) ( quot array i -- | quot: k v -- )
     over length over number= [
@@ -137,7 +143,8 @@ IN: hashtables
         3drop
     ] if-key ;
 
-: hash-size ( hash -- n ) dup hash-count swap hash-deleted - ;
+: hash-size ( hash -- n )
+    dup hash-count swap hash-deleted - ; inline
 
 : hash-empty? ( hash -- ? ) hash-size zero? ;
 
@@ -148,7 +155,7 @@ IN: hashtables
 
 : ?grow-hash ( hash -- )
     dup hash-count 3 * over hash-array length >
-    [ dup grow-hash ] when drop ;
+    [ dup grow-hash ] when drop ; inline
 
 : set-hash ( value key hash -- )
     [ (set-hash) ] keep ?grow-hash ;

library/compiler/inference/dataflow.factor

@@ -90,6 +90,10 @@ TUPLE: #terminate ;
 C: #terminate make-node ;
 : #terminate ( -- node ) empty-node <#terminate> ;
 
+TUPLE: #declare ;
+C: #declare make-node ;
+: #declare ( classes -- node ) param-node <#declare> ;
+
 : node-inputs ( d-count r-count node -- )
     tuck
     >r r-tail r> set-node-in-r

library/compiler/inference/known-words.factor

@@ -4,13 +4,14 @@ hashtables-internals interpreter io io-internals kernel
 kernel-internals lists math math-internals memory parser
 sequences strings vectors words prettyprint ;
 
-! We transform calls to these words into 'branched' forms;
+\ declare [
-! eg, there is no VOP for fixnum<=, only fixnum<= followed
+    pop-literal nip
-! by an #if, so if we have a 'bare' fixnum<= we add
+    dup length ensure-values
-! [ t ] [ f ] if at the end.
+    dup #declare [ >r length d-tail r> set-node-in-d ] keep
+    node,
+] "infer" set-word-prop
+\ declare [ [ object ] [ ] ] "infer-effect" set-word-prop
 
-! This transformation really belongs in the optimizer, but it
-! is simpler to do it here.
 \ fixnum< [ [ fixnum fixnum ] [ object ] ] "infer-effect" set-word-prop
 \ fixnum< t "flushable" set-word-prop
 \ fixnum< t "foldable" set-word-prop
@@ -31,13 +32,6 @@ sequences strings vectors words prettyprint ;
 \ eq? t "flushable" set-word-prop
 \ eq? t "foldable" set-word-prop
 
-: manual-branch ( word -- )
-    dup "infer-effect" word-prop consume/produce
-    [ [ t ] [ f ] if ] infer-quot ;
-
-! { fixnum<= fixnum< fixnum>= fixnum> eq? }
-! [ dup [ manual-branch ] curry "infer" set-word-prop ] each
-
 ! Primitive combinators
 \ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop
 

library/compiler/optimizer/call-optimizers.factor

@@ -62,6 +62,19 @@ math math-internals sequences words ;
     { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
 } define-optimizers
 
+: useless-coerce? ( node -- )
+    dup node-in-d first over node-classes ?hash
+    swap node-param "infer-effect" word-prop second first eq? ;
+
+: call>no-op ( node -- node )
+    [ ] dataflow [ subst-node ] keep ;
+
+{ >fixnum >bignum >float } [
+    {
+        { [ dup useless-coerce? ] [ call>no-op ] }
+    } define-optimizers
+] each
+
 ! Arithmetic identities
 SYMBOL: @
 

library/compiler/optimizer/class-infer.factor

@@ -134,6 +134,9 @@ M: #dispatch child-ties ( node -- seq )
     dup node-in-d first
     swap node-children length [ <literal-tie> ] map-with ;
 
+M: #declare infer-classes* ( node -- )
+    dup node-param swap node-in-d [ set-value-class* ] 2each ;
+
 DEFER: (infer-classes)
 
 : infer-children ( node -- )

library/compiler/optimizer/inline-methods.factor

@@ -71,26 +71,24 @@ M: 2generic dispatching-values drop node-in-d 2 swap tail* ;
     last-node 2dup swap post-inline set-node-successor ;
 
 : inline-method ( node -- node )
-    #! We set the #call node's param to f so that it gets killed
-    #! later.
     dup method-dataflow
     [ >r node-param r> remember-node ] 2keep
     [ subst-node ] keep ;
 
-: related? ( actual testing -- ? )
+: 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 node-in-d node-classes* first r> related?
+        >r dup node-in-d node-classes* first r> comparable?
     ] [
         2drop f
     ] if ;
 
 : inline-literals ( node literals -- node )
-    #! Make #push -> #return -> successor
+    #! Make #shuffle -> #push -> #return -> successor
     over drop-inputs [
         >r >list [ literalize ] map dataflow [ subst-node ] keep
         r> set-node-successor

library/compiler/optimizer/print-dataflow.factor

@@ -65,13 +65,7 @@ M: #dispatch node>quot ( ? node -- )
 M: #return node>quot ( ? node -- )
     dup node-param unparse "#return " swap append comment, ;
 
-M: #values node>quot ( ? node -- ) "#values" comment, ;
+M: object node>quot ( ? node -- ) dup class comment, ;
-
-M: #merge node>quot ( ? node -- ) "#merge" comment, ;
-
-M: #entry node>quot ( ? node -- ) "#entry" comment, ;
-
-M: #terminate node>quot ( ? node -- ) "#terminate" comment, ;
 
 : (dataflow>quot) ( ? node -- )
     dup [

library/compiler/optimizer/specializers.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: compiler
-USING: arrays generic kernel math namespaces sequences words ;
+USING: arrays generic hashtables kernel math namespaces
+sequences words ;
 
 : make-specializer ( quot class picker -- quot )
     over \ object eq? [
@@ -31,3 +32,10 @@ USING: arrays generic kernel math namespaces sequences words ;
 { v+ v- v* v/ vmax vmin v. } [
     { array array } "specializer" set-word-prop
 ] each
+
+\ hash* { object hashtable } "specializer" set-word-prop
+\ remove-hash { object hashtable } "specializer" set-word-prop
+\ set-hash { object object hashtable } "specializer" set-word-prop
+
+{ first first2 first3 first4 }
+[ { array } "specializer" set-word-prop ] each

library/generic/math-combination.factor

@@ -48,7 +48,7 @@ TUPLE: no-math-method left right generic ;
         2drop object-method
     ] if ;
 
-: math-vtable ( picker quot -- )
+: math-vtable ( picker quot -- quot )
     [
         swap , \ tag ,
         [ num-tags [ type>class ] map swap map % ] { } make ,
@@ -58,7 +58,7 @@ TUPLE: no-math-method left right generic ;
 : math-class? ( object -- ? )
     dup word? [ "math-priority" word-prop ] [ drop f ] if ;
 
-: math-combination ( word -- vtable )
+: math-combination ( word -- quot )
     \ over [
         dup math-class? [
             \ dup [ >r 2dup r> math-method ] math-vtable
@@ -67,5 +67,11 @@ TUPLE: no-math-method left right generic ;
         ] if nip
     ] math-vtable nip ;
 
+: partial-math-dispatch ( 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> ;
+
 PREDICATE: generic 2generic ( word -- ? )
     "combination" word-prop [ math-combination ] = ;

library/generic/slots.factor

@@ -15,20 +15,24 @@ parser sequences strings words ;
         2drop 2drop
     ] if ;
 
-: define-reader ( class slot reader -- )
+: define-reader ( class slot decl reader -- )
-    [ slot ] define-slot-word ;
+    [ slot ] rot dup object eq? [
+        drop
+    ] [
+        1array [ declare ] curry append
+    ] if define-slot-word ;
 
 : define-writer ( class slot writer -- )
     [ set-slot ] define-slot-word ;
 
-: define-slot ( class slot reader writer -- )
+: define-slot ( class slot decl reader writer -- )
-    >r >r 2dup r> define-reader r> define-writer ;
+    >r >r >r 2dup r> r> define-reader r> define-writer ;
 
 : intern-slots ( spec -- spec )
-    [ first3 [ dup [ first2 create ] when ] 2apply 3array ] map ;
+    [ [ dup array? [ first2 create ] when ] map ] map ;
 
 : define-slots ( class spec -- )
-    [ first3 define-slot ] each-with ;
+    [ first4 define-slot ] each-with ;
 
 : reader-word ( class name -- word )
     >r word-name "-" r> append3 in get 2array ;
@@ -36,10 +40,9 @@ parser sequences strings words ;
 : writer-word ( class name -- word )
     [ swap "set-" % word-name % "-" % % ] "" make in get 2array ;
 
-: simple-slot ( class name -- reader writer )
+: simple-slot ( class name -- )
-    [ reader-word ] 2keep writer-word ;
+    2dup reader-word , writer-word , ;
 
 : simple-slots ( class slots base -- spec )
     over length [ + ] map-with
-    [ >r dupd simple-slot r> -rot 3array ] 2map nip
+    [ [ , object , dupd simple-slot ] { } make ] 2map nip intern-slots ;
-    intern-slots ;

library/kernel.factor

@@ -79,6 +79,7 @@ M: wrapper literalize <wrapper> ;
 IN: kernel-internals
 
 ! These words are unsafe. Don't use them.
+: declare ( types -- ) drop ;
 
 : array-capacity 1 slot ; inline
 : array-nth swap 2 fixnum+fast slot ; inline