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.simple
|
||||
compiler.tree.propagation.constraints
|
||||
compiler.tree.propagation.call-effect ;
|
||||
compiler.tree.propagation.call-effect
|
||||
compiler.tree.propagation.transforms ;
|
||||
IN: compiler.tree.propagation.known-words
|
||||
|
||||
\ fixnum
|
||||
|
|
@ -227,39 +228,6 @@ generic-comparison-ops [
|
|||
] "outputs" set-word-prop
|
||||
] 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 }
|
||||
[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
|
||||
|
||||
|
|
@ -314,15 +282,6 @@ generic-comparison-ops [
|
|||
"outputs" 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
|
||||
|
||||
\ slot [
|
||||
dup literal?>>
|
||||
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
|
||||
|
|
@ -346,29 +305,3 @@ generic-comparison-ops [
|
|||
bi
|
||||
] [ 2drop object-info ] if
|
||||
] "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
|
||||
slots.private words hashtables classes assocs locals
|
||||
specialized-arrays.double system sorting math.libm
|
||||
math.intervals quotations ;
|
||||
math.intervals quotations effects ;
|
||||
IN: compiler.tree.propagation.tests
|
||||
|
||||
[ V{ } ] [ [ ] final-classes ] unit-test
|
||||
|
|
@ -717,3 +717,26 @@ M: number whatever drop foo ;
|
|||
: that-thing ( -- class ) foo ;
|
||||
|
||||
[ 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
|
||||
|
||||
\ 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