[RFC] Multiple dispatch with existing inline cache infrastructure and abstractions for dispatch specifiers

basis/compiler/compiler.factor

@@ -5,8 +5,8 @@ combinators.short-circuit compiler.cfg compiler.cfg.builder
 compiler.cfg.builder.alien compiler.cfg.finalization
 compiler.cfg.optimizer compiler.codegen compiler.crossref
 compiler.errors compiler.tree.builder compiler.tree.optimizer
-compiler.units compiler.utilities continuations definitions fry
-generic generic.single io kernel macros make namespaces
+compiler.units compiler.utilities continuations definitions
+generic generic.single generic.multi io kernel macros make namespaces
 sequences sets stack-checker.dependencies stack-checker.errors
 stack-checker.inlining vocabs.loader words ;
 IN: compiler
@@ -102,6 +102,8 @@ M: word combinator? inline? ;
     {
         [ single-generic? ]
         [ primitive? ]
+        [ multi-generic? ]
+        [ nested-dispatch-engine-word? ]
     } 1|| not ;
 
 : contains-breakpoints? ( -- ? )
@@ -125,12 +127,20 @@ M: word combinator? inline? ;
         ] with-cfg
     ] each ;
 
+! NOTE: this uses a mechanism which is normally only used in the code path of
+! optimized word in the compiler vocab.  The methods will still be compiled.  I
+! suppose this is more of a warning kind of thing.
+: detect-generic-errors ( generic -- )
+    [ check-generic ]
+    [ swap <compiler-error> save-compiler-error ] recover ;
+
 : compile-word ( word -- )
     ! We return early if the word has breakpoints or if it
     ! failed to infer.
     '[
         _ {
             [ start-compilation ]
+            [ detect-generic-errors ]
             [ frontend ]
             [ backend ]
             [ finish-compilation ]

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes.algebra combinators
-combinators.short-circuit compiler.tree compiler.tree.builder
+USING: accessors arrays assocs classes.algebra classes.dispatch.covariant-tuples
+combinators combinators.short-circuit compiler.tree compiler.tree.builder
 compiler.tree.normalization compiler.tree.propagation.info
-compiler.tree.propagation.nodes compiler.tree.recursive generic
-generic.math generic.single generic.standard kernel locals math
-math.partial-dispatch namespaces quotations sequences words ;
+compiler.tree.propagation.nodes compiler.tree.recursive generic generic.math
+generic.multi generic.single generic.standard kernel math math.partial-dispatch
+namespaces quotations sequences words ;
 IN: compiler.tree.propagation.inlining
 
 : splicing-call ( #call word -- nodes )
@@ -52,6 +52,20 @@ M: callable splicing-nodes splicing-body ;
 : inline-standard-method ( #call word -- ? )
     dupd inlining-standard-method eliminate-dispatch ;
 
+! FIXME: Almost copy/paste from inlining-standard-method, abstract
+! dispatch-classes or something
+: inlining-multi-method ( #call word -- class/f method/f )
+    dup "methods" word-prop assoc-empty? [ 2drop f f ] [
+        2dup [ in-d>> length ] [ multi-generic-arity ] bi* < [ 2drop f f ] [
+            [ in-d>> ] [ [ multi-generic-arity ] keep ] bi*
+            [ tail* [ value-info class>> ] map <covariant-tuple> dup ] dip
+            method-for-class
+        ] if
+    ] if ;
+
+: inline-multi-method ( #call word -- ? )
+    dupd inlining-multi-method eliminate-dispatch ;
+
 : normalize-math-class ( class -- class' )
     {
         null
@@ -107,6 +121,7 @@ SYMBOL: history
         { [ dup never-inline-word? ] [ 2drop f ] }
         { [ dup always-inline-word? ] [ inline-word ] }
         { [ dup standard-generic? ] [ inline-standard-method ] }
+        { [ dup multi-generic? ] [ inline-multi-method ] }
         { [ dup math-generic? ] [ inline-math-method ] }
         { [ dup inline? ] [ inline-word ] }
         [ 2drop f ]

basis/hints/hints.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs byte-arrays byte-vectors classes
-combinators definitions fry generic generic.single
+combinators definitions fry
+generic generic.multi generic.single
 generic.standard hashtables io.binary kernel kernel.private math
 math.parser parser sbufs sequences sequences.private splitting
 strings vectors words ;

basis/stack-checker/dependencies/dependencies.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types arrays assocs classes classes.algebra
-classes.algebra.private classes.maybe classes.tuple
-combinators.short-circuit fry generic kernel math namespaces sequences
+classes.algebra.private classes.dispatch.covariant-tuples classes.maybe
+classes.tuple combinators.short-circuit fry generic kernel math namespaces sequences
 sets words ;
 FROM: classes.tuple.private => tuple-layout ;
 IN: stack-checker.dependencies
@@ -41,6 +41,9 @@ M: anonymous-union add-depends-on-class
 M: anonymous-intersection add-depends-on-class
     participants>> [ add-depends-on-class ] each ;
 
+M: covariant-tuple add-depends-on-class
+    classes>> [ add-depends-on-class ] each ;
+
 GENERIC: add-depends-on-c-type ( c-type -- )
 
 M: void add-depends-on-c-type drop ;

core/bootstrap/syntax.factor

@@ -10,6 +10,7 @@ IN: bootstrap.syntax
     {
         "\""
         "("
+        ")"
         ":"
         ";"
         "<PRIVATE"

core/classes/algebra/algebra-tests.factor

@@ -1,4 +1,4 @@
-USING: accessors arrays assocs classes classes.algebra
+USING: accessors arrays assocs classes classes.algebra classes.algebra.private
 classes.tuple classes.union generic generic.private growable
 kernel math prettyprint quotations random sbufs sequences
 stack-checker strings tools.test vectors words ;
@@ -361,3 +361,4 @@ TUPLE: xh < xb ;
 { sa } [ sa { sa sb sc } min-class ] unit-test
 
 [ \ + flatten-class ] must-fail
+

core/classes/algebra/algebra.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes classes.private
+USING: accessors arrays assocs classes classes.private classes.dispatch
 combinators kernel make math math.order namespaces sequences
 sets sorting vectors words ;
 IN: classes.algebra
@@ -46,6 +46,8 @@ M: anonymous-complement instance?
 M: anonymous-complement class-name
     class>> class-name ;
 
+M: dispatch-type rank-class drop 9 ;
+
 DEFER: (class<=)
 
 DEFER: (class-not)
@@ -181,6 +183,8 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
                 { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
                 { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
                 { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
+                { [ over dispatch-type? ] [ left-dispatch<= ] }
+                { [ dup dispatch-type? ] [ right-dispatch<= ] }
                 [ 2drop f ]
             } cond
         ] if

core/classes/classes.factor

@@ -60,6 +60,7 @@ M: class reset-class
         "members"
         "participants"
         "predicate"
+        "disjoint"
     } remove-word-props ;
 
 M: word reset-class drop ;

core/classes/classifications/classifications-tests.factor

@@ -0,0 +1,93 @@
+USING: classes.algebra classes.classifications classes.classifications.private
+combinators.short-circuit compiler.units kernel math namespaces tools.test words
+;
+IN: classes.classifications.tests
+
+! These are disjoint subsets, with implied test order.  First match always wins.
+PREDICATE: 8bit < integer { [ 256 < ] } 1&& ;
+PREDICATE: 16bit < integer { [ 8bit? not ] [ 65536 < ] } 1&& ;
+PREDICATE: unsigned < integer { [ 8bit? not ] [ 16bit? not ] [ 0 > ] } 1&& ;
+
+GENERIC: bounds ( n -- n )
+M: 8bit bounds drop 256 ;
+M: 16bit bounds drop 65536 ;
+M: unsigned bounds drop 1/0. ;
+
+{ 256 } [ 1 bounds ] unit-test
+{ 65536 } [ 256 bounds ] unit-test
+{ 1/0. } [ 100000 bounds ] unit-test
+
+{ [ { [ 256 < ] } 1&& ] } [ V{ } [ 256 < ] exclude-negations ] unit-test
+{ [ { [ 8bit? not ] [ 65536 < ] } 1&& ] } [ V{ 8bit } [ 65536 < ] exclude-negations ] unit-test
+
+DEFER: foo1
+DEFER: foo2
+DEFER: foo1?
+DEFER: foo2?
+{ T{ classification-builder f integer V{ { foo1 [ 1 = ] } { foo2 [ 2 = ] } } } }
+[ integer [
+      \ foo1 [ 1 = ] define-classified
+      \ foo2 [ 2 = ] define-classified
+      current-classification get
+  ] with-new-classification ] unit-test
+
+{ }
+[ [ T{ classification-builder f integer V{ { foo1 [ 1 = ] } { foo2 [ 2 = ] } } }
+    finalize-classification
+  ] with-compilation-unit ] unit-test
+
+{ t } [ 1 foo1? ] unit-test
+{ f } [ 2 foo1? ] unit-test
+{ f } [ 1 foo2? ] unit-test
+{ t } [ 2 foo2? ] unit-test
+{ f } [ 3 foo1? ] unit-test
+{ f } [ 3 foo2? ] unit-test
+
+CLASSIFY integer
+AS: negative 0 < ;
+AS: 0-to-20 20 < ;
+AS: 20-to-40 40 < ;
+ELSE: above-40
+
+{ HS{ negative 0-to-20 20-to-40 } } [ above-40 "disjoint" word-prop ] unit-test
+{ HS{ negative above-40 0-to-20 } } [ 20-to-40 "disjoint" word-prop ] unit-test
+{ HS{ 0-to-20 above-40 20-to-40 } } [ negative "disjoint" word-prop ] unit-test
+
+GENERIC: upper ( number -- number )
+M: negative upper drop 0 ;
+M: 0-to-20 upper drop 20 ;
+M: 20-to-40 upper drop 40 ;
+M: above-40 upper drop 1/0. ;
+
+PREDICATE: exactly-10 < 0-to-20 10 = ;
+M: exactly-10 upper drop 11 ;
+
+{ t } [ 10 exactly-10? ] unit-test
+{ t } [ exactly-10 0-to-20 class<= ] unit-test
+{ f } [ 0-to-20 exactly-10 class<= ] unit-test
+
+{ 20 } [ 9 upper ] unit-test
+{ 11 } [ 10 upper ] unit-test
+{ 20 } [ 11 upper ] unit-test
+{ 40 } [ 30 upper ] unit-test
+{ 1/0. } [ 50 upper ] unit-test
+
+CLASSIFY negative
+AS: somewhat-negative -50 > ;
+ELSE: very-negative
+
+{ HS{ 0-to-20 above-40 20-to-40 somewhat-negative } } [ very-negative "disjoint" word-prop ] unit-test
+{ HS{ 0-to-20 above-40 20-to-40 very-negative } } [ somewhat-negative "disjoint" word-prop ] unit-test
+
+CLASSIFY above-40
+AS: below-100 100 < ;
+ELSE: very-positive
+
+! Intersection tests
+{ f } [ negative 0-to-20 classes-intersect? ] unit-test
+{ f } [ very-negative somewhat-negative classes-intersect? ] unit-test
+{ f } [ very-positive very-negative classes-intersect? ] unit-test
+{ f } [ very-positive 0-to-20 classes-intersect? ] unit-test
+
+{ t } [ very-positive above-40 classes-intersect? ] unit-test
+{ t } [ very-positive integer classes-intersect? ] unit-test

core/classes/classifications/classifications.factor

@@ -0,0 +1,60 @@
+USING: accessors arrays assocs classes.parser classes.predicate
+combinators.short-circuit hash-sets kernel namespaces parser sequences words ;
+
+IN: classes.classifications
+
+! Used for ordering of predicate classes
+
+! predicates are { name predicate-quot } pairs
+TUPLE: classification-builder base-class predicates ;
+: <classification> ( base-class -- ob )
+    V{ } clone classification-builder boa ;
+
+! PREDICATE: classified-predicate-class < predicate-class "disjoint" word-prop >boolean ;
+
+<PRIVATE
+SYMBOL: current-classification
+PRIVATE>
+
+: exclude-negations ( seq def -- def' )
+    [ [ "predicate" word-prop [ not ] compose ] map >array ] dip suffix [ 1&& ] curry ;
+
+! : define-classified-predicate-class ( classifier class superclass definition -- )
+!     [ define-predicate-class ] keepdd
+!     "classifier" [ swap prefix ] change-word-prop ;
+
+! Create a predicate class that excludes any previous predicate class
+: finalize-classification ( classification-builder -- )
+    [ predicates>> ] [ base-class>> ] bi
+    [let :> ( pred-pairs base )
+     pred-pairs keys :> preds
+     V{ } clone :> acc
+     pred-pairs [ first2 :> ( name def )
+             name base acc def exclude-negations
+             define-predicate-class
+             name preds >hash-set make-disjoint
+             name acc push
+            ] each
+     ! union-name acc >array define-union-class
+     ! union-name acc "classifies" set-word-prop
+    ] ;
+
+: with-new-classification ( base-class quot -- )
+    swap '[ _ <classification> current-classification set ]
+    prepose with-scope
+    ; inline
+
+: define-classified ( class quot -- )
+    2array
+    current-classification get predicates>> push ;
+
+DEFER: ELSE:
+SYNTAX: AS: scan-new-class parse-definition define-classified ;
+: (ELSE:) ( -- ) scan-new-class [ drop t ] define-classified ;
+
+SYNTAX: CLASSIFY scan-class
+    [
+        \ ELSE: parse-until (ELSE:)
+        [ "non-empty-parser-accumulator" throw ] unless-empty
+        current-classification get finalize-classification
+    ] with-new-classification ;

core/classes/dispatch/class/class.factor

@@ -0,0 +1,56 @@
+USING: accessors arrays classes classes.algebra classes.algebra.private
+classes.dispatch classes.private generic kernel make present sequences
+stack-checker.dependencies words ;
+
+IN: classes.dispatch.class
+
+! * Dispatching on Classes
+
+! Allows implementing class methods.
+
+TUPLE: class-specializer { class maybe{ class } read-only } ;
+
+C: <class-specializer> class-specializer
+INSTANCE: class-specializer dispatch-type
+
+M: class-specializer predicate-def
+    class>> [ class<= ] curry ;
+
+M: class-specializer class-name class>> present "class<=" prepend ;
+
+M: class-specializer implementor-classes class>> 1array ;
+
+! NOTE: Not yet 100% sure here if the semantics are correct.  While the cover of
+! a class itself is actually `{ word }`, the cover of a tuple class is '{ tuple }'.
+! The main point of this is to make sure that the methods are correctly assigned
+! to built-in or tuple classes for dispatch decision tree building.  Since
+! we want to dispatch on words, this needs to be a word, then...
+
+! NOTE: using classoid to make sure we install dispatchers for everything that
+! is comparable using class<=
+M: class-specializer (flatten-class) drop classoid (flatten-class) ;
+
+! This implements the actual hierarchy.  For class methods, we want to delegate
+! to superclasses.  Classes and objects are incomparable, so these live in their
+! own scope.
+M: class-specializer left-dispatch<=
+    dup class-specializer?
+    [ right-dispatch<= ] [ 2drop f ] if ;
+
+M: class-specializer right-dispatch<=
+    over class-specializer?
+    [ [ class>> ] bi@ class<= ] [ 2drop f ] if ;
+
+! Two classes intersect, if there are objects that can be an instance of both.
+! Two class specializers intersect, if their classes intersect.  No other
+! dispatch type can overlap with a class-specializer (Except for eql
+! specializers on class words ?)
+M: class-specializer (classes-intersect?)
+    over class-specializer?
+    [ [ class>> ] bi@ classes-intersect? ] [ 2drop f ] if ;
+
+M: class-specializer add-depends-on-class
+    class>> add-depends-on-class ;
+
+M: class-specializer dispatch-depends-on?
+    class>> class= ;