diff --git a/library/bootstrap/boot-stage1.factor b/library/bootstrap/boot-stage1.factor index 80ad224844..763606cebf 100644 --- a/library/bootstrap/boot-stage1.factor +++ b/library/bootstrap/boot-stage1.factor @@ -90,6 +90,7 @@ parser prettyprint sequences io vectors words ; "/library/inference/words.factor" "/library/inference/stack.factor" "/library/inference/partial-eval.factor" + "/library/inference/class-infer.factor" "/library/inference/optimizer.factor" "/library/inference/print-dataflow.factor" diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index e2fca26979..3e3ba54c6f 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -4,8 +4,6 @@ USING: alien assembler command-line compiler generic hashtables kernel lists memory namespaces parser sequences io unparser words ; -\ fiber? t "inline" set-word-prop - : pull-in ( ? list -- ) swap [ [ diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index b289fce50a..9fc91c25ce 100644 --- a/library/generic/builtin.factor +++ b/library/generic/builtin.factor @@ -24,13 +24,9 @@ builtin 50 "priority" set-word-prop ! All builtin types are equivalent in ordering builtin [ 2drop t ] "class<" set-word-prop -: builtin-predicate ( class -- ) - dup "predicate" word-prop car - dup t "inline" set-word-prop - swap - [ - \ type , "builtin-type" word-prop , \ eq? , - ] make-list +: builtin-predicate ( class predicate -- ) + 2dup register-predicate + [ \ type , swap "builtin-type" word-prop , \ eq? , ] make-list define-compound ; : register-builtin ( class -- ) @@ -41,8 +37,7 @@ builtin [ 2drop t ] "class<" set-word-prop dup intern-symbol dup r> "builtin-type" set-word-prop dup builtin define-class - dup r> unit "predicate" set-word-prop - dup builtin-predicate + dup r> builtin-predicate dup r> intern-slots 2dup "slots" set-word-prop define-slots register-builtin ; diff --git a/library/generic/generic.factor b/library/generic/generic.factor index 8583d246ba..f10211455d 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -8,23 +8,12 @@ math-internals ; ! A simple single-dispatch generic word system. : predicate-word ( word -- word ) - word-name "?" append create-in - dup t "inline" set-word-prop ; + word-name "?" append create-in ; -! Terminology: -! - type: a datatype built in to the runtime, eg fixnum, word -! cons. All objects have exactly one type, new types cannot be -! defined, and types are disjoint. -! - class: a user defined way of differentiating objects, either -! based on type, or some combination of type, predicate, or -! method map. -! - metaclass: a metaclass is a symbol with a handful of word -! properties: "builtin-supertypes" "priority" "add-method" -! "class<" +: register-predicate ( class predicate -- ) + 2dup unit "predicate" set-word-prop + swap "predicating" set-word-prop ; -! So far, only tuples can have delegates, which also must be -! tuples (the UI uses numbers as delegates in a couple of places -! but this is Unsupported(tm)). GENERIC: delegate GENERIC: set-delegate diff --git a/library/generic/tuple.factor b/library/generic/tuple.factor index 1486a9a1a3..d1e1e2e3d5 100644 --- a/library/generic/tuple.factor +++ b/library/generic/tuple.factor @@ -18,8 +18,6 @@ hashtables errors sequences vectors ; #! specifying an incorrect size. [ 2 set-slot ] keep ; -: class-tuple 2 slot ; inline - IN: generic DEFER: tuple? @@ -30,18 +28,15 @@ M: tuple set-delegate 3 set-slot ; : class ( obj -- class ) #! The class of an object. - dup tuple? [ class-tuple ] [ type builtin-type ] ifte ; + dup tuple? [ 2 slot ] [ type builtin-type ] ifte ; inline : tuple-predicate ( word -- ) #! Make a foo? word for testing the tuple class at the top #! of the stack. - dup predicate-word 2dup unit "predicate" set-word-prop - swap [ - [ dup tuple? ] % - [ \ class-tuple , literal, \ eq? , ] make-list , - [ drop f ] , - \ ifte , - ] make-list define-compound ; + dup predicate-word + 2dup register-predicate + swap [ \ class , literal, \ eq? , ] make-list + define-compound ; : forget-tuple ( class -- ) dup forget "predicate" word-prop car [ forget ] when* ; @@ -136,7 +131,7 @@ M: tuple set-delegate 3 set-slot ; #! for methods defined on the given generic. dup default-tuple-method \ drop swons over tuple-methods hash>quot - >r "picker" word-prop [ class-tuple ] r> append3 ; + >r "picker" word-prop [ class ] r> append3 ; : add-tuple-dispatch ( word vtable -- ) >r tuple-dispatch-quot tuple r> set-vtable ; diff --git a/library/inference/class-infer.factor b/library/inference/class-infer.factor index 5ea88d13b0..6ffe9185bc 100644 --- a/library/inference/class-infer.factor +++ b/library/inference/class-infer.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: inference -USING: generic hashtables kernel namespaces sequences words ; +USING: generic hashtables kernel namespaces sequences vectors +words ; ! Infer possible classes of values in a dataflow IR. @@ -10,54 +11,121 @@ USING: generic hashtables kernel namespaces sequences words ; ! Current value --> class mapping SYMBOL: value-classes -TUPLE: possibility value class ; +! Current value --> literal mapping +SYMBOL: value-literals -! Maps possibilities to possibilities. -SYMBOL: possible-classes +GENERIC: apply-tie ( tie -- ) + +M: f apply-tie ( f -- ) drop ; + +TUPLE: class-tie value class ; + +: set-value-class ( class value -- ) + 2dup swap ties get hash [ apply-tie ] when* + value-classes get set-hash ; + +M: class-tie apply-tie ( tie -- ) + dup class-tie-class swap class-tie-value + set-value-class ; + +TUPLE: literal-tie value literal ; + +: set-value-literal ( literal value -- ) + over class over set-value-class + 2dup swap ties get hash [ apply-tie ] when* + value-literals get set-hash ; + +M: literal-tie apply-tie ( tie -- ) + dup literal-tie-literal swap literal-tie-value + set-value-literal ; + +! Maps ties to ties +SYMBOL: ties GENERIC: infer-classes* ( node -- ) +M: node infer-classes* ( node -- ) drop ; + +! For conditionals, a map of child node # --> possibility +GENERIC: child-ties ( node -- seq ) + +M: node child-ties ( node -- seq ) + node-children length f ; + : value-class ( value -- class ) value-classes get hash [ object ] unless* ; +: value-literal ( value -- class ) + value-literals get hash ; + : annotate-node ( node -- ) #! Annotate the node with the currently-inferred set of #! value classes. - dup node-values [ value-class ] map>hash - swap set-node-classes ; - -M: node infer-classes* ( node -- ) drop ; + dup node-values ( 2dup ) + [ value-class ] map>hash swap set-node-classes + ( [ value-literal ] map>hash swap set-node-literals ) ; : assume-classes ( classes values -- ) - [ value-classes get set-hash ] 2each ; + [ set-value-class ] 2each ; + +: assume-literals ( literals values -- ) + [ set-value-literal ] 2each ; : intersect-classes ( classes values -- ) [ [ value-class class-and ] 2map ] keep assume-classes ; +: create-ties ( #call -- ) + #! If the node is calling a class test predicate, create a + #! tie. + dup node-param "predicating" word-prop dup [ + >r dup node-in-d first r> + swap node-out-d first general-t + ties get set-hash + ] [ + 2drop + ] ifte ; + M: #call infer-classes* ( node -- ) + dup create-ties dup node-param "infer-effect" word-prop 2unseq pick node-out-d assume-classes swap node-in-d intersect-classes ; M: #push infer-classes* ( node -- ) - node-out-d [ - dup safe-literal? [ - [ literal-value class ] keep - value-classes get set-hash - ] [ - drop - ] ifte - ] each ; + node-out-d [ safe-literal? ] subset + dup [ literal-value ] map + swap assume-literals ; + +M: #ifte child-ties ( node -- seq ) + node-in-d first dup general-t + swap f 2vector ; + +M: #dispatch child-ties ( node -- seq ) + dup node-in-d first + swap node-children length [ ] map-with ; + +DEFER: (infer-classes) + +: infer-children ( node -- ) + dup node-children swap child-ties [ + [ + value-classes [ clone ] change + ties [ clone ] change + apply-tie + (infer-classes) + ] with-scope + ] 2each ; : (infer-classes) ( node -- ) dup infer-classes* dup annotate-node - dup node-children [ (infer-classes) ] each + dup infer-children node-successor [ (infer-classes) ] when* ; : infer-classes ( node -- ) [ value-classes set - possible-classes set + value-literals set + ties set (infer-classes) ] with-scope ; diff --git a/library/inference/dataflow.factor b/library/inference/dataflow.factor index d8d8d09acd..9b37f89856 100644 --- a/library/inference/dataflow.factor +++ b/library/inference/dataflow.factor @@ -9,12 +9,12 @@ sequences vectors words ; ! code with stack flow information and types. TUPLE: node param in-d out-d in-r out-r - classes successor children ; + classes literals successor children ; M: node = eq? ; : make-node ( param in-d out-d in-r out-r node -- node ) - [ >r f f f r> set-delegate ] keep ; + [ >r f f f f r> set-delegate ] keep ; : param-node ( label) f f f f ; : in-d-node ( inputs) >r f r> f f f ; diff --git a/library/inference/optimizer.factor b/library/inference/optimizer.factor index 7b76cb4e3e..4226ee19e2 100644 --- a/library/inference/optimizer.factor +++ b/library/inference/optimizer.factor @@ -92,7 +92,7 @@ M: f can-kill* ( literal node -- ? ) 2drop t ; M: node can-kill* ( literal node -- ? ) - uses-value? ; + uses-value? not ; M: node kill-node* ( literals node -- ) 2drop ; diff --git a/library/inference/print-dataflow.factor b/library/inference/print-dataflow.factor index aa202bf0fa..7a97c456e3 100644 --- a/library/inference/print-dataflow.factor +++ b/library/inference/print-dataflow.factor @@ -14,7 +14,7 @@ M: annotation prettyprint* ( ann -- ) swap annotation-node object. ; : value-str ( classes values -- str ) - [ swap ?hash [ [ object ] ] unless* ] map-with + [ swap ?hash [ object ] unless* ] map-with [ word-name ] map " " join ; diff --git a/library/test/gadgets/gradients.factor b/library/test/gadgets/gradients.factor index 32211f9edb..320d6fa307 100644 --- a/library/test/gadgets/gradients.factor +++ b/library/test/gadgets/gradients.factor @@ -5,18 +5,18 @@ USING: gadgets namespaces styles test ; 0 x set 0 y set - [ [ 255 0 0 ] ] [ { 1 0 0 } red green 0 gradient-color ] unit-test - [ [ 0 255 0 ] ] [ { 1 0 0 } red green 1 gradient-color ] unit-test + [ { 255 0 0 } ] [ { 1 0 0 } red green 0 gradient-color ] unit-test + [ { 0 255 0 } ] [ { 1 0 0 } red green 1 gradient-color ] unit-test - [ 0 100 0 [ 255 0 0 ] ] + [ 0 100 0 { 255 0 0 } ] [ { 0 1 0 } red green { 100 200 0 } 0 (gradient-x) ] unit-test [ 0 100 100 [ 255/2 255/2 0 ] ] [ { 0 1 0 } red green { 100 200 0 } 100 (gradient-x) ] unit-test - [ 0 0 200 [ 255 0 0 ] ] + [ 0 0 200 { 255 0 0 } ] [ { 1 0 0 } red green { 100 200 0 } 0 (gradient-y) ] unit-test - [ 50 0 200 [ 255/2 255/2 0 ] ] + [ 50 0 200 { 255/2 255/2 0 } ] [ { 1 0 0 } red green { 100 200 0 } 50 (gradient-y) ] unit-test ] with-scope diff --git a/library/test/lists/combinators.factor b/library/test/lists/combinators.factor index 302edcc65e..60f56e6273 100644 --- a/library/test/lists/combinators.factor +++ b/library/test/lists/combinators.factor @@ -8,7 +8,6 @@ USE: strings USE: sequences [ { [ 3 2 1 ] [ 5 4 3 ] [ 6 ] } ] -[ [ 1 2 3 ] [ 3 4 5 ] [ 6 ] 3vector [ reverse ] map ] unit-test [ [ "a" 43 [ ] ] ] [ [ "a" 43 43 43 [ ] 43 "a" [ ] ] prune ] unit-test diff --git a/library/test/redefine.factor b/library/test/redefine.factor index e97d95b3fa..a17c9f963c 100644 --- a/library/test/redefine.factor +++ b/library/test/redefine.factor @@ -8,4 +8,4 @@ USE: test : foo 1 2 3 ; [ 1 2 3 1 2 3 ] [ bar ] unit-test -[ [ [ ] [ fixnum fixnum fixnum ] ] ] [ [ foo ] infer ] unit-test +[ [ [ 0 3 ] ] ] [ [ foo ] infer ] unit-test diff --git a/library/test/sequences.factor b/library/test/sequences.factor index b750c908c7..bf40857b14 100644 --- a/library/test/sequences.factor +++ b/library/test/sequences.factor @@ -69,3 +69,5 @@ unit-test [ { 1 2 3 } ] [ 1 2 3 3vector ] unit-test [ { } ] [ { } seq-transpose ] unit-test + +[ [ 1 2 3 ] [ 3 4 5 ] [ 6 ] 3vector [ reverse ] map ] unit-test