define-partial-eval framework in propagation pass makes it easy to add transforms; moving some transforms from stack checker to propagation, making them stronger
Daniel Ehrenberg
parent
b4c522f045
commit
ee3e84a1f8
|
|
@ -14,7 +14,8 @@ compiler.tree.propagation.nodes
|
||||||
compiler.tree.propagation.slots
|
compiler.tree.propagation.slots
|
||||||
compiler.tree.propagation.simple
|
compiler.tree.propagation.simple
|
||||||
compiler.tree.propagation.constraints
|
compiler.tree.propagation.constraints
|
||||||
compiler.tree.propagation.call-effect ;
|
compiler.tree.propagation.call-effect
|
||||||
|
compiler.tree.propagation.transforms ;
|
||||||
IN: compiler.tree.propagation.known-words
|
IN: compiler.tree.propagation.known-words
|
||||||
|
|
||||||
\ fixnum
|
\ fixnum
|
||||||
|
|
@ -227,39 +228,6 @@ generic-comparison-ops [
|
||||||
] "outputs" set-word-prop
|
] "outputs" set-word-prop
|
||||||
] assoc-each
|
] assoc-each
|
||||||
|
|
||||||
: rem-custom-inlining ( #call -- quot/f )
|
|
||||||
second value-info literal>> dup integer?
|
|
||||||
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
|
|
||||||
|
|
||||||
{
|
|
||||||
mod-integer-integer
|
|
||||||
mod-integer-fixnum
|
|
||||||
mod-fixnum-integer
|
|
||||||
fixnum-mod
|
|
||||||
} [
|
|
||||||
[
|
|
||||||
in-d>> dup first value-info interval>> [0,inf] interval-subset?
|
|
||||||
[ rem-custom-inlining ] [ drop f ] if
|
|
||||||
] "custom-inlining" set-word-prop
|
|
||||||
] each
|
|
||||||
|
|
||||||
\ rem [
|
|
||||||
in-d>> rem-custom-inlining
|
|
||||||
] "custom-inlining" set-word-prop
|
|
||||||
|
|
||||||
{
|
|
||||||
bitand-integer-integer
|
|
||||||
bitand-integer-fixnum
|
|
||||||
bitand-fixnum-integer
|
|
||||||
} [
|
|
||||||
[
|
|
||||||
in-d>> second value-info >literal< [
|
|
||||||
0 most-positive-fixnum between?
|
|
||||||
[ [ >fixnum ] bi@ fixnum-bitand ] f ?
|
|
||||||
] when
|
|
||||||
] "custom-inlining" set-word-prop
|
|
||||||
] each
|
|
||||||
|
|
||||||
{ numerator denominator }
|
{ numerator denominator }
|
||||||
[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
|
[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
|
||||||
|
|
||||||
|
|
@ -314,15 +282,6 @@ generic-comparison-ops [
|
||||||
"outputs" set-word-prop
|
"outputs" set-word-prop
|
||||||
] each
|
] each
|
||||||
|
|
||||||
! Generate more efficient code for common idiom
|
|
||||||
\ clone [
|
|
||||||
in-d>> first value-info literal>> {
|
|
||||||
{ V{ } [ [ drop { } 0 vector boa ] ] }
|
|
||||||
{ H{ } [ [ drop 0 <hashtable> ] ] }
|
|
||||||
[ drop f ]
|
|
||||||
} case
|
|
||||||
] "custom-inlining" set-word-prop
|
|
||||||
|
|
||||||
\ slot [
|
\ slot [
|
||||||
dup literal?>>
|
dup literal?>>
|
||||||
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
|
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
|
||||||
|
|
@ -346,29 +305,3 @@ generic-comparison-ops [
|
||||||
bi
|
bi
|
||||||
] [ 2drop object-info ] if
|
] [ 2drop object-info ] if
|
||||||
] "outputs" set-word-prop
|
] "outputs" set-word-prop
|
||||||
|
|
||||||
\ instance? [
|
|
||||||
in-d>> second value-info literal>> dup class?
|
|
||||||
[ "predicate" word-prop '[ drop @ ] ] [ drop f ] if
|
|
||||||
] "custom-inlining" set-word-prop
|
|
||||||
|
|
||||||
\ equal? [
|
|
||||||
! If first input has a known type and second input is an
|
|
||||||
! object, we convert this to [ swap equal? ].
|
|
||||||
in-d>> first2 value-info class>> object class= [
|
|
||||||
value-info class>> \ equal? specific-method
|
|
||||||
[ swap equal? ] f ?
|
|
||||||
] [ drop f ] if
|
|
||||||
] "custom-inlining" set-word-prop
|
|
||||||
|
|
||||||
: inline-new ( class -- quot/f )
|
|
||||||
dup tuple-class? [
|
|
||||||
dup inlined-dependency depends-on
|
|
||||||
[ all-slots [ initial>> literalize ] map ]
|
|
||||||
[ tuple-layout '[ _ <tuple-boa> ] ]
|
|
||||||
bi append [ drop ] prepend >quotation
|
|
||||||
] [ drop f ] if ;
|
|
||||||
|
|
||||||
\ new [
|
|
||||||
in-d>> first value-info literal>> inline-new
|
|
||||||
] "custom-inlining" set-word-prop
|
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use
|
||||||
compiler.tree.debugger compiler.tree.checker
|
compiler.tree.debugger compiler.tree.checker
|
||||||
slots.private words hashtables classes assocs locals
|
slots.private words hashtables classes assocs locals
|
||||||
specialized-arrays.double system sorting math.libm
|
specialized-arrays.double system sorting math.libm
|
||||||
math.intervals quotations ;
|
math.intervals quotations effects ;
|
||||||
IN: compiler.tree.propagation.tests
|
IN: compiler.tree.propagation.tests
|
||||||
|
|
||||||
[ V{ } ] [ [ ] final-classes ] unit-test
|
[ V{ } ] [ [ ] final-classes ] unit-test
|
||||||
|
|
@ -717,3 +717,26 @@ M: number whatever drop foo ;
|
||||||
: that-thing ( -- class ) foo ;
|
: that-thing ( -- class ) foo ;
|
||||||
|
|
||||||
[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
|
[ f ] [ [ that-thing new ] { new } inlined? ] unit-test
|
||||||
|
|
||||||
|
GENERIC: whatever2 ( x -- y )
|
||||||
|
M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ;
|
||||||
|
M: f whatever2 ;
|
||||||
|
|
||||||
|
[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
|
||||||
|
[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
|
||||||
|
[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test
|
||||||
|
[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test
|
||||||
|
[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test
|
||||||
|
|
||||||
|
[ f ] [ [ instance? ] { instance? } inlined? ] unit-test
|
||||||
|
[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test
|
||||||
|
[ t ] [ [ array instance? ] { instance? } inlined? ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test
|
||||||
|
[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,2 @@
|
||||||
|
Slava Pestov
|
||||||
|
Daniel Ehrenberg
|
||||||
|
|
@ -0,0 +1,195 @@
|
||||||
|
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||||
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
|
USING: kernel sequences words fry generic accessors classes.tuple
|
||||||
|
classes classes.algebra definitions stack-checker.state quotations
|
||||||
|
classes.tuple.private math math.partial-dispatch math.private
|
||||||
|
math.intervals layouts math.order vectors hashtables
|
||||||
|
combinators effects generalizations assocs sets
|
||||||
|
combinators.short-circuit sequences.private locals
|
||||||
|
stack-checker
|
||||||
|
compiler.tree.propagation.info ;
|
||||||
|
IN: compiler.tree.propagation.transforms
|
||||||
|
|
||||||
|
\ equal? [
|
||||||
|
! If first input has a known type and second input is an
|
||||||
|
! object, we convert this to [ swap equal? ].
|
||||||
|
in-d>> first2 value-info class>> object class= [
|
||||||
|
value-info class>> \ equal? specific-method
|
||||||
|
[ swap equal? ] f ?
|
||||||
|
] [ drop f ] if
|
||||||
|
] "custom-inlining" set-word-prop
|
||||||
|
|
||||||
|
: rem-custom-inlining ( #call -- quot/f )
|
||||||
|
second value-info literal>> dup integer?
|
||||||
|
[ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
|
||||||
|
|
||||||
|
{
|
||||||
|
mod-integer-integer
|
||||||
|
mod-integer-fixnum
|
||||||
|
mod-fixnum-integer
|
||||||
|
fixnum-mod
|
||||||
|
} [
|
||||||
|
[
|
||||||
|
in-d>> dup first value-info interval>> [0,inf] interval-subset?
|
||||||
|
[ rem-custom-inlining ] [ drop f ] if
|
||||||
|
] "custom-inlining" set-word-prop
|
||||||
|
] each
|
||||||
|
|
||||||
|
\ rem [
|
||||||
|
in-d>> rem-custom-inlining
|
||||||
|
] "custom-inlining" set-word-prop
|
||||||
|
|
||||||
|
{
|
||||||
|
bitand-integer-integer
|
||||||
|
bitand-integer-fixnum
|
||||||
|
bitand-fixnum-integer
|
||||||
|
} [
|
||||||
|
[
|
||||||
|
in-d>> second value-info >literal< [
|
||||||
|
0 most-positive-fixnum between?
|
||||||
|
[ [ >fixnum ] bi@ fixnum-bitand ] f ?
|
||||||
|
] when
|
||||||
|
] "custom-inlining" set-word-prop
|
||||||
|
] each
|
||||||
|
|
||||||
|
! Generate more efficient code for common idiom
|
||||||
|
\ clone [
|
||||||
|
in-d>> first value-info literal>> {
|
||||||
|
{ V{ } [ [ drop { } 0 vector boa ] ] }
|
||||||
|
{ H{ } [ [ drop 0 <hashtable> ] ] }
|
||||||
|
[ drop f ]
|
||||||
|
} case
|
||||||
|
] "custom-inlining" set-word-prop
|
||||||
|
|
||||||
|
: prepare-partial-eval ( #call n -- value-infos ? )
|
||||||
|
|
||||||
|
ERROR: bad-partial-eval quot word ;
|
||||||
|
|
||||||
|
: check-effect ( quot word -- )
|
||||||
|
2dup [ infer ] [ stack-effect ] bi* effect<=
|
||||||
|
[ 2drop ] [ bad-partial-eval ] if ;
|
||||||
|
|
||||||
|
: values ( #call n -- infos )
|
||||||
|
[ in-d>> ] dip tail* [ value-info ] map ;
|
||||||
|
|
||||||
|
:: define-partial-eval ( word quot n -- )
|
||||||
|
word [
|
||||||
|
n values
|
||||||
|
dup [ literal?>> ] all? [
|
||||||
|
[ literal>> ] map
|
||||||
|
n firstn
|
||||||
|
quot call dup [
|
||||||
|
[ n ndrop ] prepose
|
||||||
|
dup word check-effect
|
||||||
|
] when
|
||||||
|
] [ drop f ] if
|
||||||
|
] "custom-inlining" set-word-prop ;
|
||||||
|
|
||||||
|
: inline-new ( class -- quot/f )
|
||||||
|
dup tuple-class? [
|
||||||
|
dup inlined-dependency depends-on
|
||||||
|
[ all-slots [ initial>> literalize ] map ]
|
||||||
|
[ tuple-layout '[ _ <tuple-boa> ] ]
|
||||||
|
bi append >quotation
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
||||||
|
\ new [ inline-new ] 1 define-partial-eval
|
||||||
|
|
||||||
|
\ instance? [
|
||||||
|
dup class?
|
||||||
|
[ "predicate" word-prop ] [ drop f ] if
|
||||||
|
] 1 define-partial-eval
|
||||||
|
|
||||||
|
! Shuffling
|
||||||
|
: nths-quot ( indices -- quot )
|
||||||
|
[ [ '[ _ swap nth ] ] map ] [ length ] bi
|
||||||
|
'[ _ cleave _ narray ] ;
|
||||||
|
|
||||||
|
\ shuffle [
|
||||||
|
shuffle-mapping nths-quot
|
||||||
|
] 1 define-partial-eval
|
||||||
|
|
||||||
|
! Index search
|
||||||
|
\ index [
|
||||||
|
dup sequence? [
|
||||||
|
dup length 4 >= [
|
||||||
|
dup length zip >hashtable '[ _ at ]
|
||||||
|
] [ drop f ] if
|
||||||
|
] [ drop f ] if
|
||||||
|
] 1 define-partial-eval
|
||||||
|
|
||||||
|
: memq-quot ( seq -- newquot )
|
||||||
|
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
|
||||||
|
[ drop f ] suffix [ cond ] curry ;
|
||||||
|
|
||||||
|
\ memq? [
|
||||||
|
dup sequence? [ memq-quot ] [ drop f ] if
|
||||||
|
] 1 define-partial-eval
|
||||||
|
|
||||||
|
! Membership testing
|
||||||
|
: member-quot ( seq -- newquot )
|
||||||
|
dup length 4 <= [
|
||||||
|
[ drop f ] swap
|
||||||
|
[ literalize [ t ] ] { } map>assoc linear-case-quot
|
||||||
|
] [
|
||||||
|
unique [ key? ] curry
|
||||||
|
] if ;
|
||||||
|
|
||||||
|
\ member? [
|
||||||
|
dup sequence? [ member-quot ] [ drop f ] if
|
||||||
|
] 1 define-partial-eval
|
||||||
|
|
||||||
|
! Fast at for integer maps
|
||||||
|
CONSTANT: lookup-table-at-max 256
|
||||||
|
|
||||||
|
: lookup-table-at? ( assoc -- ? )
|
||||||
|
#! Can we use a fast byte array test here?
|
||||||
|
{
|
||||||
|
[ assoc-size 4 > ]
|
||||||
|
[ values [ ] all? ]
|
||||||
|
[ keys [ integer? ] all? ]
|
||||||
|
[ keys [ 0 lookup-table-at-max between? ] all? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: lookup-table-seq ( assoc -- table )
|
||||||
|
[ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
|
||||||
|
|
||||||
|
: lookup-table-quot ( seq -- newquot )
|
||||||
|
lookup-table-seq
|
||||||
|
'[
|
||||||
|
_ over integer? [
|
||||||
|
2dup bounds-check? [
|
||||||
|
nth-unsafe dup >boolean
|
||||||
|
] [ 2drop f f ] if
|
||||||
|
] [ 2drop f f ] if
|
||||||
|
] ;
|
||||||
|
|
||||||
|
: fast-lookup-table-at? ( assoc -- ? )
|
||||||
|
values {
|
||||||
|
[ [ integer? ] all? ]
|
||||||
|
[ [ 0 254 between? ] all? ]
|
||||||
|
} 1&& ;
|
||||||
|
|
||||||
|
: fast-lookup-table-seq ( assoc -- table )
|
||||||
|
lookup-table-seq [ 255 or ] B{ } map-as ;
|
||||||
|
|
||||||
|
: fast-lookup-table-quot ( seq -- newquot )
|
||||||
|
fast-lookup-table-seq
|
||||||
|
'[
|
||||||
|
_ over integer? [
|
||||||
|
2dup bounds-check? [
|
||||||
|
nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
|
||||||
|
] [ 2drop f f ] if
|
||||||
|
] [ 2drop f f ] if
|
||||||
|
] ;
|
||||||
|
|
||||||
|
: at-quot ( assoc -- quot )
|
||||||
|
dup lookup-table-at? [
|
||||||
|
dup fast-lookup-table-at? [
|
||||||
|
fast-lookup-table-quot
|
||||||
|
] [
|
||||||
|
lookup-table-quot
|
||||||
|
] if
|
||||||
|
] [ drop f ] if ;
|
||||||
|
|
||||||
|
\ at* [ at-quot ] 1 define-partial-eval
|
||||||
|
|
@ -107,97 +107,3 @@ IN: stack-checker.transforms
|
||||||
] 1 define-transform
|
] 1 define-transform
|
||||||
|
|
||||||
\ boa t "no-compile" set-word-prop
|
\ boa t "no-compile" set-word-prop
|
||||||
|
|
||||||
! Fast at for integer maps
|
|
||||||
CONSTANT: lookup-table-at-max 256
|
|
||||||
|
|
||||||
: lookup-table-at? ( assoc -- ? )
|
|
||||||
#! Can we use a fast byte array test here?
|
|
||||||
{
|
|
||||||
[ assoc-size 4 > ]
|
|
||||||
[ values [ ] all? ]
|
|
||||||
[ keys [ integer? ] all? ]
|
|
||||||
[ keys [ 0 lookup-table-at-max between? ] all? ]
|
|
||||||
} 1&& ;
|
|
||||||
|
|
||||||
: lookup-table-seq ( assoc -- table )
|
|
||||||
[ keys supremum 1+ ] keep '[ _ at ] { } map-as ;
|
|
||||||
|
|
||||||
: lookup-table-quot ( seq -- newquot )
|
|
||||||
lookup-table-seq
|
|
||||||
'[
|
|
||||||
_ over integer? [
|
|
||||||
2dup bounds-check? [
|
|
||||||
nth-unsafe dup >boolean
|
|
||||||
] [ 2drop f f ] if
|
|
||||||
] [ 2drop f f ] if
|
|
||||||
] ;
|
|
||||||
|
|
||||||
: fast-lookup-table-at? ( assoc -- ? )
|
|
||||||
values {
|
|
||||||
[ [ integer? ] all? ]
|
|
||||||
[ [ 0 254 between? ] all? ]
|
|
||||||
} 1&& ;
|
|
||||||
|
|
||||||
: fast-lookup-table-seq ( assoc -- table )
|
|
||||||
lookup-table-seq [ 255 or ] B{ } map-as ;
|
|
||||||
|
|
||||||
: fast-lookup-table-quot ( seq -- newquot )
|
|
||||||
fast-lookup-table-seq
|
|
||||||
'[
|
|
||||||
_ over integer? [
|
|
||||||
2dup bounds-check? [
|
|
||||||
nth-unsafe dup 255 eq? [ drop f f ] [ t ] if
|
|
||||||
] [ 2drop f f ] if
|
|
||||||
] [ 2drop f f ] if
|
|
||||||
] ;
|
|
||||||
|
|
||||||
: at-quot ( assoc -- quot )
|
|
||||||
dup lookup-table-at? [
|
|
||||||
dup fast-lookup-table-at? [
|
|
||||||
fast-lookup-table-quot
|
|
||||||
] [
|
|
||||||
lookup-table-quot
|
|
||||||
] if
|
|
||||||
] [ drop f ] if ;
|
|
||||||
|
|
||||||
\ at* [ at-quot ] 1 define-transform
|
|
||||||
|
|
||||||
! Membership testing
|
|
||||||
: member-quot ( seq -- newquot )
|
|
||||||
dup length 4 <= [
|
|
||||||
[ drop f ] swap
|
|
||||||
[ literalize [ t ] ] { } map>assoc linear-case-quot
|
|
||||||
] [
|
|
||||||
unique [ key? ] curry
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
\ member? [
|
|
||||||
dup sequence? [ member-quot ] [ drop f ] if
|
|
||||||
] 1 define-transform
|
|
||||||
|
|
||||||
: memq-quot ( seq -- newquot )
|
|
||||||
[ [ dupd eq? ] curry [ drop t ] ] { } map>assoc
|
|
||||||
[ drop f ] suffix [ cond ] curry ;
|
|
||||||
|
|
||||||
\ memq? [
|
|
||||||
dup sequence? [ memq-quot ] [ drop f ] if
|
|
||||||
] 1 define-transform
|
|
||||||
|
|
||||||
! Index search
|
|
||||||
\ index [
|
|
||||||
dup sequence? [
|
|
||||||
dup length 4 >= [
|
|
||||||
dup length zip >hashtable '[ _ at ]
|
|
||||||
] [ drop f ] if
|
|
||||||
] [ drop f ] if
|
|
||||||
] 1 define-transform
|
|
||||||
|
|
||||||
! Shuffling
|
|
||||||
: nths-quot ( indices -- quot )
|
|
||||||
[ [ '[ _ swap nth ] ] map ] [ length ] bi
|
|
||||||
'[ _ cleave _ narray ] ;
|
|
||||||
|
|
||||||
\ shuffle [
|
|
||||||
shuffle-mapping nths-quot
|
|
||||||
] 1 define-transform
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue